Commit cca2d6b7 authored by Michal Terepeta's avatar Michal Terepeta Committed by Ben Gamari

Allow packing constructor fields

This is another step for fixing #13825 and is based on D38 by Simon
Marlow.

The change allows storing multiple constructor fields within the same
word. This currently applies only to `Float`s, e.g.,
```
data Foo = Foo {-# UNPACK #-} !Float {-# UNPACK #-} !Float
```
on 64-bit arch, will now store both fields within the same constructor
word. For `WordX/IntX` we'll need to introduce new primop types.

Main changes:

- We now use sizes in bytes when we compute the offsets for
  constructor fields in `StgCmmLayout` and introduce padding if
  necessary (word-sized fields are still word-aligned)

- `ByteCodeGen` had to be updated to correctly construct the data
  types. This required some new bytecode instructions to allow pushing
  things that are not full words onto the stack (and updating
  `Interpreter.c`). Note that we only use the packed stuff when
  constructing data types (i.e., for `PACK`), in all other cases the
  behavior should not change.

- `RtClosureInspect` was changed to handle the new layout when
  extracting subterms. This seems to be used by things like `:print`.
  I've also added a test for this.

- I deviated slightly from Simon's approach and use `PrimRep` instead
  of `ArgRep` for computing the size of fields.  This seemed more
  natural and in the future we'll probably want to introduce new
  primitive types (e.g., `Int8#`) and `PrimRep` seems like a better
  place to do that (where we already have `Int64Rep` for example).
  `ArgRep` on the other hand seems to be more focused on calling
  functions.
Signed-off-by: Michal Terepeta's avatarMichal Terepeta <michal.terepeta@gmail.com>

Test Plan: ./validate

Reviewers: bgamari, simonmar, austin, hvr, goldfire, erikd

Reviewed By: bgamari

Subscribers: maoe, rwbarton, thomie

GHC Trac Issues: #13825

Differential Revision: https://phabricator.haskell.org/D3809
parent 85aa1f42
...@@ -131,9 +131,10 @@ assignStack dflags offset arg_ty args = assign_stk offset [] (reverse args) ...@@ -131,9 +131,10 @@ assignStack dflags offset arg_ty args = assign_stk offset [] (reverse args)
assign_stk offset assts (r:rs) assign_stk offset assts (r:rs)
= assign_stk off' ((r, StackParam off') : assts) rs = assign_stk off' ((r, StackParam off') : assts) rs
where w = typeWidth (arg_ty r) where w = typeWidth (arg_ty r)
size = (((widthInBytes w - 1) `div` word_size) + 1) * word_size
off' = offset + size off' = offset + size
word_size = wORD_SIZE dflags -- Stack arguments always take a whole number of words, we never
-- pack them unlike constructor fields.
size = roundUpToWords dflags (widthInBytes w)
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- Local information about the registers available -- Local information about the registers available
......
...@@ -9,7 +9,7 @@ module SMRep ( ...@@ -9,7 +9,7 @@ module SMRep (
-- * Words and bytes -- * Words and bytes
WordOff, ByteOff, WordOff, ByteOff,
wordsToBytes, bytesToWordsRoundUp, wordsToBytes, bytesToWordsRoundUp,
roundUpToWords, roundUpToWords, roundUpTo,
StgWord, fromStgWord, toStgWord, StgWord, fromStgWord, toStgWord,
StgHalfWord, fromStgHalfWord, toStgHalfWord, StgHalfWord, fromStgHalfWord, toStgHalfWord,
...@@ -79,8 +79,11 @@ type ByteOff = Int ...@@ -79,8 +79,11 @@ type ByteOff = Int
-- | Round up the given byte count to the next byte count that's a -- | Round up the given byte count to the next byte count that's a
-- multiple of the machine's word size. -- multiple of the machine's word size.
roundUpToWords :: DynFlags -> ByteOff -> ByteOff roundUpToWords :: DynFlags -> ByteOff -> ByteOff
roundUpToWords dflags n = roundUpToWords dflags n = roundUpTo n (wORD_SIZE dflags)
(n + (wORD_SIZE dflags - 1)) .&. (complement (wORD_SIZE dflags - 1))
-- | Round up @base@ to a multiple of @size@.
roundUpTo :: ByteOff -> ByteOff -> ByteOff
roundUpTo base size = (base + (size - 1)) .&. (complement (size - 1))
-- | Convert the given number of words to a number of bytes. -- | Convert the given number of words to a number of bytes.
-- --
......
...@@ -112,7 +112,7 @@ cgTopRhsClosure dflags rec id ccs _ upd_flag args body = ...@@ -112,7 +112,7 @@ cgTopRhsClosure dflags rec id ccs _ upd_flag args body =
-- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY) -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY)
; emitDataLits closure_label closure_rep ; emitDataLits closure_label closure_rep
; let fv_details :: [(NonVoid Id, VirtualHpOffset)] ; let fv_details :: [(NonVoid Id, ByteOff)]
(_, _, fv_details) = mkVirtHeapOffsets dflags (isLFThunk lf_info) [] (_, _, fv_details) = mkVirtHeapOffsets dflags (isLFThunk lf_info) []
-- Don't drop the non-void args until the closure info has been made -- Don't drop the non-void args until the closure info has been made
; forkClosureBody (closureCodeBody True id closure_info ccs ; forkClosureBody (closureCodeBody True id closure_info ccs
......
...@@ -79,9 +79,16 @@ cgTopRhsCon dflags id con args = ...@@ -79,9 +79,16 @@ cgTopRhsCon dflags id con args =
-- LAY IT OUT -- LAY IT OUT
; let ; let
is_thunk = False
(tot_wds, -- #ptr_wds + #nonptr_wds (tot_wds, -- #ptr_wds + #nonptr_wds
ptr_wds, -- #ptr_wds ptr_wds, -- #ptr_wds
nv_args_w_offsets) = mkVirtConstrOffsets dflags (addArgReps args) nv_args_w_offsets) =
mkVirtHeapOffsetsWithPadding dflags is_thunk (addArgReps args)
mk_payload (Padding len _) = return (CmmInt 0 (widthFromBytes len))
mk_payload (FieldOff arg _) = do
CmmLit lit <- getArgAmode arg
return lit
nonptr_wds = tot_wds - ptr_wds nonptr_wds = tot_wds - ptr_wds
...@@ -90,10 +97,8 @@ cgTopRhsCon dflags id con args = ...@@ -90,10 +97,8 @@ cgTopRhsCon dflags id con args =
-- needs to poke around inside it. -- needs to poke around inside it.
info_tbl = mkDataConInfoTable dflags con True ptr_wds nonptr_wds info_tbl = mkDataConInfoTable dflags con True ptr_wds nonptr_wds
get_lit (arg, _offset) = do { CmmLit lit <- getArgAmode arg
; return lit }
; payload <- mapM get_lit nv_args_w_offsets ; payload <- mapM mk_payload nv_args_w_offsets
-- NB1: nv_args_w_offsets is sorted into ptrs then non-ptrs -- NB1: nv_args_w_offsets is sorted into ptrs then non-ptrs
-- NB2: all the amodes should be Lits! -- NB2: all the amodes should be Lits!
-- TODO (osa): Why? -- TODO (osa): Why?
...@@ -264,7 +269,7 @@ bindConArgs (DataAlt con) base args ...@@ -264,7 +269,7 @@ bindConArgs (DataAlt con) base args
-- The binding below forces the masking out of the tag bits -- The binding below forces the masking out of the tag bits
-- when accessing the constructor field. -- when accessing the constructor field.
bind_arg :: (NonVoid Id, VirtualHpOffset) -> FCode (Maybe LocalReg) bind_arg :: (NonVoid Id, ByteOff) -> FCode (Maybe LocalReg)
bind_arg (arg@(NonVoid b), offset) bind_arg (arg@(NonVoid b), offset)
| isDeadBinder b = | isDeadBinder b =
-- Do not load unused fields from objects to local variables. -- Do not load unused fields from objects to local variables.
......
...@@ -221,24 +221,11 @@ mkStaticClosure :: DynFlags -> CLabel -> CostCentreStack -> [CmmLit] ...@@ -221,24 +221,11 @@ mkStaticClosure :: DynFlags -> CLabel -> CostCentreStack -> [CmmLit]
mkStaticClosure dflags info_lbl ccs payload padding static_link_field saved_info_field mkStaticClosure dflags info_lbl ccs payload padding static_link_field saved_info_field
= [CmmLabel info_lbl] = [CmmLabel info_lbl]
++ staticProfHdr dflags ccs ++ staticProfHdr dflags ccs
++ concatMap (padLitToWord dflags) payload ++ payload
++ padding ++ padding
++ static_link_field ++ static_link_field
++ saved_info_field ++ saved_info_field
-- JD: Simon had elided this padding, but without it the C back end asserts
-- failure. Maybe it's a bad assertion, and this padding is indeed unnecessary?
padLitToWord :: DynFlags -> CmmLit -> [CmmLit]
padLitToWord dflags lit = lit : padding pad_length
where width = typeWidth (cmmLitType dflags lit)
pad_length = wORD_SIZE dflags - widthInBytes width :: Int
padding n | n <= 0 = []
| n `rem` 2 /= 0 = CmmInt 0 W8 : padding (n-1)
| n `rem` 4 /= 0 = CmmInt 0 W16 : padding (n-2)
| n `rem` 8 /= 0 = CmmInt 0 W32 : padding (n-4)
| otherwise = CmmInt 0 W64 : padding (n-8)
----------------------------------------------------------- -----------------------------------------------------------
-- Heap overflow checking -- Heap overflow checking
----------------------------------------------------------- -----------------------------------------------------------
......
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
...@@ -17,7 +18,12 @@ module StgCmmLayout ( ...@@ -17,7 +18,12 @@ module StgCmmLayout (
slowCall, directCall, slowCall, directCall,
mkVirtHeapOffsets, mkVirtConstrOffsets, mkVirtConstrSizes, getHpRelOffset, FieldOffOrPadding(..),
mkVirtHeapOffsets,
mkVirtHeapOffsetsWithPadding,
mkVirtConstrOffsets,
mkVirtConstrSizes,
getHpRelOffset,
ArgRep(..), toArgRep, argRepSizeW -- re-exported from StgCmmArgRep ArgRep(..), toArgRep, argRepSizeW -- re-exported from StgCmmArgRep
) where ) where
...@@ -44,7 +50,7 @@ import CmmInfo ...@@ -44,7 +50,7 @@ import CmmInfo
import CLabel import CLabel
import StgSyn import StgSyn
import Id import Id
import TyCon ( PrimRep(..) ) import TyCon ( PrimRep(..), primRepSizeB )
import BasicTypes ( RepArity ) import BasicTypes ( RepArity )
import DynFlags import DynFlags
import Module import Module
...@@ -387,26 +393,33 @@ getHpRelOffset virtual_offset ...@@ -387,26 +393,33 @@ getHpRelOffset virtual_offset
hp_usg <- getHpUsage hp_usg <- getHpUsage
return (cmmRegOffW dflags hpReg (hpRel (realHp hp_usg) virtual_offset)) return (cmmRegOffW dflags hpReg (hpRel (realHp hp_usg) virtual_offset))
mkVirtHeapOffsets data FieldOffOrPadding a
= FieldOff (NonVoid a) -- Something that needs an offset.
ByteOff -- Offset in bytes.
| Padding ByteOff -- Length of padding in bytes.
ByteOff -- Offset in bytes.
mkVirtHeapOffsetsWithPadding
:: DynFlags :: DynFlags
-> Bool -- True <=> is a thunk -> Bool -- True <=> is a thunk
-> [NonVoid (PrimRep,a)] -- Things to make offsets for -> [NonVoid (PrimRep, a)] -- Things to make offsets for
-> (WordOff, -- _Total_ number of words allocated -> ( WordOff -- Total number of words allocated
WordOff, -- Number of words allocated for *pointers* , WordOff -- Number of words allocated for *pointers*
[(NonVoid a, ByteOff)]) , [FieldOffOrPadding a] -- Either an offset or padding.
)
-- Things with their offsets from start of object in order of -- Things with their offsets from start of object in order of
-- increasing offset; BUT THIS MAY BE DIFFERENT TO INPUT ORDER -- increasing offset; BUT THIS MAY BE DIFFERENT TO INPUT ORDER
-- First in list gets lowest offset, which is initial offset + 1. -- First in list gets lowest offset, which is initial offset + 1.
-- --
-- mkVirtHeapOffsets always returns boxed things with smaller offsets -- mkVirtHeapOffsetsWithPadding always returns boxed things with smaller offsets
-- than the unboxed things -- than the unboxed things
mkVirtHeapOffsets dflags is_thunk things mkVirtHeapOffsetsWithPadding dflags is_thunk things =
= ASSERT(not (any (isVoidRep . fst . fromNonVoid) things)) ASSERT(not (any (isVoidRep . fst . fromNonVoid) things))
( bytesToWordsRoundUp dflags tot_bytes ( tot_wds
, bytesToWordsRoundUp dflags bytes_of_ptrs , bytesToWordsRoundUp dflags bytes_of_ptrs
, ptrs_w_offsets ++ non_ptrs_w_offsets , concat (ptrs_w_offsets ++ non_ptrs_w_offsets) ++ final_pad
) )
where where
hdr_words | is_thunk = thunkHdrSize dflags hdr_words | is_thunk = thunkHdrSize dflags
...@@ -420,10 +433,58 @@ mkVirtHeapOffsets dflags is_thunk things ...@@ -420,10 +433,58 @@ mkVirtHeapOffsets dflags is_thunk things
(tot_bytes, non_ptrs_w_offsets) = (tot_bytes, non_ptrs_w_offsets) =
mapAccumL computeOffset bytes_of_ptrs non_ptrs mapAccumL computeOffset bytes_of_ptrs non_ptrs
computeOffset bytes_so_far nv_thing tot_wds = bytesToWordsRoundUp dflags tot_bytes
= (bytes_so_far + wordsToBytes dflags (argRepSizeW dflags (toArgRep rep)),
(NonVoid thing, hdr_bytes + bytes_so_far)) final_pad_size = tot_wds * word_size - tot_bytes
where (rep,thing) = fromNonVoid nv_thing final_pad
| final_pad_size > 0 = [(Padding final_pad_size
(hdr_bytes + tot_bytes))]
| otherwise = []
word_size = wORD_SIZE dflags
computeOffset bytes_so_far nv_thing =
(new_bytes_so_far, with_padding field_off)
where
(rep, thing) = fromNonVoid nv_thing
-- Size of the field in bytes.
!sizeB = primRepSizeB dflags rep
-- Align the start offset (eg, 2-byte value should be 2-byte aligned).
-- But not more than to a word.
!align = min word_size sizeB
!start = roundUpTo bytes_so_far align
!padding = start - bytes_so_far
-- Final offset is:
-- size of header + bytes_so_far + padding
!final_offset = hdr_bytes + bytes_so_far + padding
!new_bytes_so_far = start + sizeB
field_off = FieldOff (NonVoid thing) final_offset
with_padding field_off
| padding == 0 = [field_off]
| otherwise = [ Padding padding (hdr_bytes + bytes_so_far)
, field_off
]
mkVirtHeapOffsets
:: DynFlags
-> Bool -- True <=> is a thunk
-> [NonVoid (PrimRep,a)] -- Things to make offsets for
-> (WordOff, -- _Total_ number of words allocated
WordOff, -- Number of words allocated for *pointers*
[(NonVoid a, ByteOff)])
mkVirtHeapOffsets dflags is_thunk things =
( tot_wds
, ptr_wds
, [ (field, offset) | (FieldOff field offset) <- things_offsets ]
)
where
(tot_wds, ptr_wds, things_offsets) =
mkVirtHeapOffsetsWithPadding dflags is_thunk things
-- | Just like mkVirtHeapOffsets, but for constructors -- | Just like mkVirtHeapOffsets, but for constructors
mkVirtConstrOffsets mkVirtConstrOffsets
......
...@@ -1677,8 +1677,8 @@ lintCoercion co@(UnivCo prov r ty1 ty2) ...@@ -1677,8 +1677,8 @@ lintCoercion co@(UnivCo prov r ty1 ty2)
= do { dflags <- getDynFlags = do { dflags <- getDynFlags
; checkWarnL (isUnBoxed rep1 == isUnBoxed rep2) ; checkWarnL (isUnBoxed rep1 == isUnBoxed rep2)
(report "between unboxed and boxed value") (report "between unboxed and boxed value")
; checkWarnL (TyCon.primRepSizeW dflags rep1 ; checkWarnL (TyCon.primRepSizeB dflags rep1
== TyCon.primRepSizeW dflags rep2) == TyCon.primRepSizeB dflags rep2)
(report "between unboxed values of different size") (report "between unboxed values of different size")
; let fl = liftM2 (==) (TyCon.primRepIsFloat rep1) ; let fl = liftM2 (==) (TyCon.primRepIsFloat rep1)
(TyCon.primRepIsFloat rep2) (TyCon.primRepIsFloat rep2)
......
...@@ -351,6 +351,12 @@ assembleI dflags i = case i of ...@@ -351,6 +351,12 @@ assembleI dflags i = case i of
PUSH_L o1 -> emit bci_PUSH_L [SmallOp o1] PUSH_L o1 -> emit bci_PUSH_L [SmallOp o1]
PUSH_LL o1 o2 -> emit bci_PUSH_LL [SmallOp o1, SmallOp o2] PUSH_LL o1 o2 -> emit bci_PUSH_LL [SmallOp o1, SmallOp o2]
PUSH_LLL o1 o2 o3 -> emit bci_PUSH_LLL [SmallOp o1, SmallOp o2, SmallOp o3] PUSH_LLL o1 o2 o3 -> emit bci_PUSH_LLL [SmallOp o1, SmallOp o2, SmallOp o3]
PUSH8 o1 -> emit bci_PUSH8 [SmallOp o1]
PUSH16 o1 -> emit bci_PUSH16 [SmallOp o1]
PUSH32 o1 -> emit bci_PUSH32 [SmallOp o1]
PUSH8_W o1 -> emit bci_PUSH8_W [SmallOp o1]
PUSH16_W o1 -> emit bci_PUSH16_W [SmallOp o1]
PUSH32_W o1 -> emit bci_PUSH32_W [SmallOp o1]
PUSH_G nm -> do p <- ptr (BCOPtrName nm) PUSH_G nm -> do p <- ptr (BCOPtrName nm)
emit bci_PUSH_G [Op p] emit bci_PUSH_G [Op p]
PUSH_PRIMOP op -> do p <- ptr (BCOPtrPrimOp op) PUSH_PRIMOP op -> do p <- ptr (BCOPtrPrimOp op)
...@@ -365,6 +371,15 @@ assembleI dflags i = case i of ...@@ -365,6 +371,15 @@ assembleI dflags i = case i of
-> do let ul_bco = assembleBCO dflags proto -> do let ul_bco = assembleBCO dflags proto
p <- ioptr (liftM BCOPtrBCO ul_bco) p <- ioptr (liftM BCOPtrBCO ul_bco)
emit (push_alts pk) [Op p] emit (push_alts pk) [Op p]
PUSH_PAD8 -> emit bci_PUSH_PAD8 []
PUSH_PAD16 -> emit bci_PUSH_PAD16 []
PUSH_PAD32 -> emit bci_PUSH_PAD32 []
PUSH_UBX8 lit -> do np <- literal lit
emit bci_PUSH_UBX8 [Op np]
PUSH_UBX16 lit -> do np <- literal lit
emit bci_PUSH_UBX16 [Op np]
PUSH_UBX32 lit -> do np <- literal lit
emit bci_PUSH_UBX32 [Op np]
PUSH_UBX lit nws -> do np <- literal lit PUSH_UBX lit nws -> do np <- literal lit
emit bci_PUSH_UBX [Op np, SmallOp nws] emit bci_PUSH_UBX [Op np, SmallOp nws]
......
...@@ -47,8 +47,9 @@ import Unique ...@@ -47,8 +47,9 @@ import Unique
import FastString import FastString
import Panic import Panic
import StgCmmClosure ( NonVoid(..), fromNonVoid, nonVoidIds ) import StgCmmClosure ( NonVoid(..), fromNonVoid, nonVoidIds )
import StgCmmLayout ( ArgRep(..), toArgRep, argRepSizeW, import StgCmmLayout ( ArgRep(..), FieldOffOrPadding(..),
mkVirtHeapOffsets, mkVirtConstrOffsets ) toArgRep, argRepSizeW,
mkVirtHeapOffsetsWithPadding, mkVirtConstrOffsets )
import SMRep hiding (WordOff, ByteOff, wordsToBytes) import SMRep hiding (WordOff, ByteOff, wordsToBytes)
import Bitmap import Bitmap
import OrdList import OrdList
...@@ -455,6 +456,9 @@ truncIntegral16 w ...@@ -455,6 +456,9 @@ truncIntegral16 w
| otherwise | otherwise
= fromIntegral w = fromIntegral w
trunc16B :: ByteOff -> Word16
trunc16B = truncIntegral16
trunc16W :: WordOff -> Word16 trunc16W :: WordOff -> Word16
trunc16W = truncIntegral16 trunc16W = truncIntegral16
...@@ -798,10 +802,13 @@ mkConAppCode orig_d _ p con args_r_to_l = ...@@ -798,10 +802,13 @@ mkConAppCode orig_d _ p con args_r_to_l =
, not (isVoidRep prim_rep) , not (isVoidRep prim_rep)
] ]
is_thunk = False is_thunk = False
(_, _, args_offsets) = mkVirtHeapOffsets dflags is_thunk non_voids (_, _, args_offsets) =
mkVirtHeapOffsetsWithPadding dflags is_thunk non_voids
do_pushery !d ((arg, _) : args) = do do_pushery !d (arg : args) = do
(push, arg_bytes) <- pushAtom d p (fromNonVoid arg) (push, arg_bytes) <- case arg of
(Padding l _) -> pushPadding l
(FieldOff a _) -> pushConstrAtom d p (fromNonVoid a)
more_push_code <- do_pushery (d + arg_bytes) args more_push_code <- do_pushery (d + arg_bytes) args
return (push `appOL` more_push_code) return (push `appOL` more_push_code)
do_pushery !d [] = do do_pushery !d [] = do
...@@ -926,7 +933,8 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple ...@@ -926,7 +933,8 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
| otherwise = wordSize dflags | otherwise = wordSize dflags
-- depth of stack after the return value has been pushed -- depth of stack after the return value has been pushed
d_bndr = d + ret_frame_size_b + idSizeB dflags bndr d_bndr =
d + ret_frame_size_b + wordsToBytes dflags (idSizeW dflags bndr)
-- depth of stack after the extra info table for an unboxed return -- depth of stack after the extra info table for an unboxed return
-- has been pushed, if any. This is the stack depth at the -- has been pushed, if any. This is the stack depth at the
...@@ -1127,8 +1135,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l ...@@ -1127,8 +1135,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
code_n_reps <- pargs d0 args_r_to_l code_n_reps <- pargs d0 args_r_to_l
let let
(pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps (pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps
a_reps_sizeW = a_reps_sizeW = sum (map (repSizeWords dflags) a_reps_pushed_r_to_l)
WordOff (sum (map (primRepSizeW dflags) a_reps_pushed_r_to_l))
push_args = concatOL pushs_arg push_args = concatOL pushs_arg
!d_after_args = d0 + wordsToBytes dflags a_reps_sizeW !d_after_args = d0 + wordsToBytes dflags a_reps_sizeW
...@@ -1218,7 +1225,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l ...@@ -1218,7 +1225,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
-- Push the return placeholder. For a call returning nothing, -- Push the return placeholder. For a call returning nothing,
-- this is a V (tag). -- this is a V (tag).
r_sizeW = WordOff (primRepSizeW dflags r_rep) r_sizeW = repSizeWords dflags r_rep
d_after_r = d_after_Addr + wordsToBytes dflags r_sizeW d_after_r = d_after_Addr + wordsToBytes dflags r_sizeW
push_r = push_r =
if returns_void if returns_void
...@@ -1472,12 +1479,20 @@ pushAtom d p (AnnVar var) ...@@ -1472,12 +1479,20 @@ pushAtom d p (AnnVar var)
| Just d_v <- lookupBCEnv_maybe var p -- var is a local variable | Just d_v <- lookupBCEnv_maybe var p -- var is a local variable
= do dflags <- getDynFlags = do dflags <- getDynFlags
-- Currently this code assumes that @szb@ is a multiple of full words.
-- It'll need to change to support, e.g., sub-word constructor fields. let !szb = idSizeCon dflags var
let !szb = idSizeB dflags var with_instr instr = do
!szw = bytesToWords dflags szb -- szb is a multiple of words let !off_b = trunc16B $ d - d_v
l = trunc16W $ bytesToWords dflags (d - d_v) + szw - 1 return (unitOL (instr off_b), wordSize dflags)
return (toOL (genericReplicate szw (PUSH_L l)), szb)
case szb of
1 -> with_instr PUSH8_W
2 -> with_instr PUSH16_W
4 -> with_instr PUSH32_W
_ -> do
let !szw = bytesToWords dflags szb
!off_w = trunc16W $ bytesToWords dflags (d - d_v) + szw - 1
return (toOL (genericReplicate szw (PUSH_L off_w)), szb)
-- d - d_v offset from TOS to the first slot of the object -- d - d_v offset from TOS to the first slot of the object
-- --
-- d - d_v + sz - 1 offset from the TOS of the last slot of the object -- d - d_v + sz - 1 offset from the TOS of the last slot of the object
...@@ -1492,7 +1507,7 @@ pushAtom d p (AnnVar var) ...@@ -1492,7 +1507,7 @@ pushAtom d p (AnnVar var)
ptrToWordPtr $ fromRemotePtr ptr ptrToWordPtr $ fromRemotePtr ptr
Nothing -> do Nothing -> do
dflags <- getDynFlags dflags <- getDynFlags
let sz = idSizeB dflags var let sz = idSizeCon dflags var
MASSERT( sz == wordSize dflags ) MASSERT( sz == wordSize dflags )
return (unitOL (PUSH_G (getName var)), sz) return (unitOL (PUSH_G (getName var)), sz)
...@@ -1525,6 +1540,36 @@ pushAtom _ _ expr ...@@ -1525,6 +1540,36 @@ pushAtom _ _ expr
(pprCoreExpr (deAnnotate' expr)) (pprCoreExpr (deAnnotate' expr))
-- | Push an atom for constructor (i.e., PACK instruction) onto the stack.
-- This is slightly different to @pushAtom@ due to the fact that we allow
-- packing constructor fields. See also @mkConAppCode@ and @pushPadding@.
pushConstrAtom
:: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM (BCInstrList, ByteOff)
pushConstrAtom _ _ (AnnLit lit@(MachFloat _)) =
return (unitOL (PUSH_UBX32 lit), 4)
pushConstrAtom d p (AnnVar v)
| Just d_v <- lookupBCEnv_maybe v p = do -- v is a local variable
dflags <- getDynFlags
let !szb = idSizeCon dflags v
done instr = do
let !off = trunc16B $ d - d_v
return (unitOL (instr off), szb)
case szb of
1 -> done PUSH8
2 -> done PUSH16
4 -> done PUSH32
_ -> pushAtom d p (AnnVar v)
pushConstrAtom d p expr = pushAtom d p expr
pushPadding :: Int -> BcM (BCInstrList, ByteOff)
pushPadding 1 = return (unitOL (PUSH_PAD8), 1)
pushPadding 2 = return (unitOL (PUSH_PAD16), 2)
pushPadding 4 = return (unitOL (PUSH_PAD32), 4)
pushPadding x = panic $ "pushPadding x=" ++ show x
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
-- Given a bunch of alts code and their discrs, do the donkey work -- Given a bunch of alts code and their discrs, do the donkey work
-- of making a multiway branch using a switch tree. -- of making a multiway branch using a switch tree.
...@@ -1669,8 +1714,8 @@ lookupBCEnv_maybe = Map.lookup ...@@ -1669,8 +1714,8 @@ lookupBCEnv_maybe = Map.lookup
idSizeW :: DynFlags -> Id -> WordOff idSizeW :: DynFlags -> Id -> WordOff
idSizeW dflags = WordOff . argRepSizeW dflags . bcIdArgRep idSizeW dflags = WordOff . argRepSizeW dflags . bcIdArgRep
idSizeB :: DynFlags -> Id -> ByteOff idSizeCon :: DynFlags -> Id -> ByteOff
idSizeB dflags = wordsToBytes dflags . idSizeW dflags idSizeCon dflags = ByteOff . primRepSizeB dflags . bcIdPrimRep
bcIdArgRep :: Id -> ArgRep bcIdArgRep :: Id -> ArgRep
bcIdArgRep = toArgRep . bcIdPrimRep bcIdArgRep = toArgRep . bcIdPrimRep
...@@ -1682,6 +1727,9 @@ bcIdPrimRep id ...@@ -1682,6 +1727,9 @@ bcIdPrimRep id
| otherwise | otherwise
= pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id)) = pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id))
repSizeWords :: DynFlags -> PrimRep -> WordOff
repSizeWords dflags rep = WordOff $ argRepSizeW dflags (toArgRep rep)
isFollowableArg :: ArgRep -> Bool isFollowableArg :: ArgRep -> Bool
isFollowableArg P = True isFollowableArg P = True
isFollowableArg _ = False isFollowableArg _ = False
......
...@@ -62,6 +62,23 @@ data BCInstr ...@@ -62,6 +62,23 @@ data BCInstr
| PUSH_LL !Word16 !Word16{-2 offsets-} | PUSH_LL !Word16 !Word16{-2 offsets-}
| PUSH_LLL !Word16 !Word16 !Word16{-3 offsets-} | PUSH_LLL !Word16 !Word16 !Word16{-3 offsets-}
-- Push the specified local as a 8, 16, 32 bit value onto the stack. (i.e.,
-- the stack will grow by 8, 16 or 32 bits)
| PUSH8 !Word16
| PUSH16 !Word16
| PUSH32 !Word16
-- Push the specifiec local as a 8, 16, 32 bit value onto the stack, but the