|
1
|
1
|
{-# language GADTs, LambdaCase #-}
|
|
2
|
2
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
3
|
+{-# LANGUAGE MultiWayIf #-}
|
|
|
4
|
+{-# LANGUAGE PatternSynonyms #-}
|
|
|
5
|
+{-# LANGUAGE ViewPatterns #-}
|
|
3
|
6
|
|
|
4
|
7
|
module GHC.CmmToAsm.AArch64.CodeGen (
|
|
5
|
8
|
cmmTopCodeGen
|
| ... |
... |
@@ -923,18 +926,23 @@ getRegister' config plat expr |
|
923
|
926
|
-- XX Conversion
|
|
924
|
927
|
CmmMachOp (MO_XX_Conv from to) [e] -> do
|
|
925
|
928
|
register <- getRegister e
|
|
926
|
|
- if to >= W32 || to > from
|
|
927
|
|
- then case register of
|
|
928
|
|
- -- Reuse computation, casting width.
|
|
929
|
|
- Any _fmt code -> pure $ Any (intFormat to) code
|
|
930
|
|
- Fixed _fmt reg code -> pure $ Fixed (intFormat to) reg code
|
|
931
|
|
- else case register of
|
|
932
|
|
- Any _fmt code ->
|
|
933
|
|
- pure $ Any (intFormat to) $ \dst -> do
|
|
934
|
|
- code dst `appOL` truncateSubwordRegInplace to dst
|
|
935
|
|
- Fixed _fmt reg code -> do
|
|
936
|
|
- (trunc_reg, trunc_code) <- truncateSubwordReg to reg
|
|
937
|
|
- pure $ Fixed (intFormat to) trunc_reg (code `appOL` trunc_code)
|
|
|
929
|
+ -- if to >= W32 || to > from
|
|
|
930
|
+ -- -- don't do anything in the word case or
|
|
|
931
|
+ -- -- when the target register width is larger
|
|
|
932
|
+ -- -- than the origin register width; e.g.
|
|
|
933
|
+ -- -- mangoiv: what we the tradeoff to not truncate here, too?
|
|
|
934
|
+ -- then case register of
|
|
|
935
|
+ -- -- Reuse computation, casting width.
|
|
|
936
|
+ -- Any _fmt code -> pure $ Any (intFormat to) code
|
|
|
937
|
+ -- Fixed _fmt reg code -> pure $ Fixed (intFormat to) reg code
|
|
|
938
|
+ -- else
|
|
|
939
|
+ case register of
|
|
|
940
|
+ Any _fmt code ->
|
|
|
941
|
+ pure $ Any (intFormat to) $ \dst -> do
|
|
|
942
|
+ code dst `appOL` truncateSubwordRegInplace to dst
|
|
|
943
|
+ Fixed _fmt reg code -> do
|
|
|
944
|
+ (trunc_reg, trunc_code) <- truncateSubwordReg SMayClobberSubwordArgReg to reg
|
|
|
945
|
+ pure $ Fixed (intFormat to) trunc_reg (code `appOL` trunc_code)
|
|
938
|
946
|
CmmMachOp op [e] -> do
|
|
939
|
947
|
(reg, _format, code) <- getSomeReg e
|
|
940
|
948
|
case op of
|
| ... |
... |
@@ -1233,7 +1241,7 @@ getRegister' config plat expr |
|
1233
|
1241
|
-- sign-extend both arguments to 32-bits.
|
|
1234
|
1242
|
-- See Note [Signed arithmetic on AArch64].
|
|
1235
|
1243
|
intOpImm :: Bool -> Width -> (Operand -> Operand -> Operand -> OrdList Instr) -> (Integer -> Width -> Maybe Operand) -> NatM (Register)
|
|
1236
|
|
- intOpImm {- is signed -} True w op _encode_imm = intOp True w op
|
|
|
1244
|
+ intOpImm True w op _encode_imm = intOp True w op {- is signed -}
|
|
1237
|
1245
|
intOpImm False w op encode_imm = do
|
|
1238
|
1246
|
-- compute x<m> <- x
|
|
1239
|
1247
|
-- compute x<o> <- y
|
| ... |
... |
@@ -1272,8 +1280,9 @@ getRegister' config plat expr |
|
1272
|
1280
|
let w' = opRegWidth w
|
|
1273
|
1281
|
signExt r
|
|
1274
|
1282
|
-- See Note [Signed arithmetic on AArch64] and #27430
|
|
1275
|
|
- | w >= W32 = pure (r, nilOL)
|
|
1276
|
|
- | not is_signed = truncateSubwordReg w r
|
|
|
1283
|
+ | not is_signed = truncateSubwordReg SMayClobberSubwordArgReg w r
|
|
|
1284
|
+ -- TODO(mangoiv) in the signed case if w> W32,
|
|
|
1285
|
+ -- this should be a noop
|
|
1277
|
1286
|
| otherwise = signExtendReg w w' r
|
|
1278
|
1287
|
(reg_x_sx, code_x_sx) <- signExt reg_x
|
|
1279
|
1288
|
(reg_y_sx, code_y_sx) <- signExt reg_y
|
| ... |
... |
@@ -1914,38 +1923,97 @@ signExtendReg w w' r = |
|
1914
|
1923
|
r' <- getNewRegNat (intFormat w')
|
|
1915
|
1924
|
return (r', unitOL $ instr (OpReg w' r') (OpReg w r))
|
|
1916
|
1925
|
|
|
1917
|
|
--- | Truncate/zero extend the subwords high bits and store the
|
|
1918
|
|
--- result in a new register. Must be called with w==8 or w==16
|
|
1919
|
|
-truncateSubwordReg :: Width -> Reg -> NatM (Reg, OrdList Instr)
|
|
1920
|
|
-truncateSubwordReg w_to r = do
|
|
1921
|
|
- massertPpr (w_to == W8 || w_to == W16) (text "truncateSubwordReg:unexpectedWidth")
|
|
1922
|
|
- case w_to of
|
|
1923
|
|
- -- Asserted false, but be defensive for non-debug builds.
|
|
1924
|
|
- W64 -> trunc W64 MOV
|
|
1925
|
|
- W32 -> trunc W32 MOV
|
|
1926
|
|
-
|
|
1927
|
|
- -- Actual truncation
|
|
1928
|
|
- W16 -> trunc W32 UXTH
|
|
1929
|
|
- W8 -> trunc W32 UXTB
|
|
1930
|
|
- _ -> panic "truncateSubwordReg:unexpectedWidth"
|
|
1931
|
|
- where
|
|
1932
|
|
- trunc w instr = do
|
|
1933
|
|
- r' <- getNewRegNat (intFormat w_to)
|
|
1934
|
|
- return (r', unitOL $ instr (OpReg w r') (OpReg w r))
|
|
|
1926
|
+-- | Whether the argument register may be clobbered
|
|
|
1927
|
+-- 'NeverClobbers' is an optimization
|
|
|
1928
|
+data ArgumentClobbering
|
|
|
1929
|
+ = NeverClobbers
|
|
|
1930
|
+ | MayClobberArgReg
|
|
|
1931
|
+
|
|
|
1932
|
+-- TODO(mangoiv): come up with better names for these two data strucutes
|
|
|
1933
|
+
|
|
|
1934
|
+data SArgumentClobbering (a :: ArgumentClobbering) where
|
|
|
1935
|
+ SMayClobberSubwordArgReg :: SArgumentClobbering MayClobberArgReg
|
|
|
1936
|
+ -- ^ the usual case: the register that holds a subword argument may be
|
|
|
1937
|
+ -- clobbered by the truncation operation; >=W32 is not affected since
|
|
|
1938
|
+ -- it is a noop
|
|
|
1939
|
+
|
|
|
1940
|
+ SAlwaysAllocateReg :: SArgumentClobbering MayClobberArgReg
|
|
|
1941
|
+ -- ^ subwords may be clobbered, but >=W32 want to allocate a new register
|
|
|
1942
|
+ -- anyway; to avoid having to allocate twice in the subword case, we
|
|
|
1943
|
+ -- always allocate a new register
|
|
|
1944
|
+ -- This is at worst a pessimisation of allocating one more registeer
|
|
|
1945
|
+ -- in case we don't actually need this.
|
|
|
1946
|
+
|
|
|
1947
|
+ SNeverClobbers :: SArgumentClobbering NeverClobbers
|
|
|
1948
|
+ -- ^ if we are sure that the register is fresh and clobbering doesn't
|
|
|
1949
|
+ -- matter, we don't have to allocate a new register, ever
|
|
|
1950
|
+
|
|
|
1951
|
+
|
|
|
1952
|
+data SArgumentClobbered (a :: ArgumentClobbering) where
|
|
|
1953
|
+ SNeverClobbered :: OrdList Instr -> SArgumentClobbered NeverClobbers
|
|
|
1954
|
+ -- ^ just returns the instructions; since we never clobber, this is pure since
|
|
|
1955
|
+ -- we never have to return a new register
|
|
|
1956
|
+
|
|
|
1957
|
+ SUnclobbered :: NatM (Reg, OrdList Instr) -> SArgumentClobbered MayClobberArgReg
|
|
|
1958
|
+ -- ^ return code to allocate a new register and instructions that may depend on it, that is:
|
|
|
1959
|
+ -- - a new register if we pass a subword register with the potential to be clobbered
|
|
|
1960
|
+ -- - the input register if we pass a word sized argument with no need to always allocate
|
|
|
1961
|
+ -- a new register
|
|
|
1962
|
+ -- - a new register if we were to always create a new register
|
|
|
1963
|
+
|
|
|
1964
|
+instrsWithUnclobberedReg :: SArgumentClobbered MayClobberArgReg -> NatM (Reg, OrdList Instr)
|
|
|
1965
|
+instrsWithUnclobberedReg (SUnclobbered a) = a
|
|
|
1966
|
+
|
|
|
1967
|
+instrsNonclobberedCode :: SArgumentClobbered NeverClobbers -> OrdList Instr
|
|
|
1968
|
+instrsNonclobberedCode (SNeverClobbered a) = a
|
|
|
1969
|
+
|
|
|
1970
|
+-- | full words
|
|
|
1971
|
+pattern WFull :: Width
|
|
|
1972
|
+pattern WFull <- (\case W32 -> True; W64 -> True; _ -> False -> True)
|
|
|
1973
|
+
|
|
|
1974
|
+-- | subwords
|
|
|
1975
|
+pattern WSub :: (Operand -> Operand -> Instr) -> Width
|
|
|
1976
|
+pattern WSub {truncInstr} <- (\case W16 -> Just UXTH; W8 -> Just UXTB; _ -> Nothing -> (Just truncInstr))
|
|
1935
|
1977
|
|
|
1936
|
|
--- | Like @truncateSubwordReg@, but modifes the argument register in place if we
|
|
1937
|
|
--- need to truncate.
|
|
1938
|
1978
|
truncateSubwordRegInplace :: Width -> Reg -> OrdList Instr
|
|
1939
|
|
-truncateSubwordRegInplace w_to r = do
|
|
1940
|
|
- case w_to of
|
|
1941
|
|
- W64 -> nilOL
|
|
1942
|
|
- W32 -> nilOL
|
|
1943
|
|
- W16 -> trunc UXTH
|
|
1944
|
|
- W8 -> trunc UXTB
|
|
1945
|
|
- _ -> panic "truncateSubwordRegInplace:unexpectedWidth"
|
|
|
1979
|
+truncateSubwordRegInplace w_to r = instrsNonclobberedCode (truncateSubwordReg' SNeverClobbers w_to r)
|
|
|
1980
|
+
|
|
|
1981
|
+truncateSubwordReg :: SArgumentClobbering MayClobberArgReg -> Width -> Reg -> NatM (Reg, OrdList Instr)
|
|
|
1982
|
+truncateSubwordReg clobbering w_to r = instrsWithUnclobberedReg (truncateSubwordReg' clobbering w_to r)
|
|
|
1983
|
+
|
|
|
1984
|
+-- | Truncate/zero extend the subwords high bits and store the
|
|
|
1985
|
+-- result in a new register.
|
|
|
1986
|
+truncateSubwordReg' :: SArgumentClobbering a -> Width -> Reg -> SArgumentClobbered a
|
|
|
1987
|
+truncateSubwordReg' clobbering w_to r = case clobbering of
|
|
|
1988
|
+ SMayClobberSubwordArgReg
|
|
|
1989
|
+ -- return the input register
|
|
|
1990
|
+ | WFull <- w_to -> SUnclobbered $ pure (r, nilOL)
|
|
|
1991
|
+ -- allocate a new register
|
|
|
1992
|
+ | WSub {truncInstr} <- w_to -> SUnclobbered $ do
|
|
|
1993
|
+ freshReg <- getNewRegNat (intFormat w_to)
|
|
|
1994
|
+ pure (freshReg, pureTrunc truncInstr W32 freshReg r)
|
|
|
1995
|
+
|
|
|
1996
|
+ -- always allocate a new register as the surrounding code
|
|
|
1997
|
+ -- would allocate one anyways and we don't want to allocate
|
|
|
1998
|
+ -- multiple times; this may be a pessimation when we don't
|
|
|
1999
|
+ -- want to allocate a new register for non-subwords
|
|
|
2000
|
+ SAlwaysAllocateReg -> SUnclobbered $ do
|
|
|
2001
|
+ freshReg <- getNewRegNat (intFormat w_to)
|
|
|
2002
|
+ let instrs
|
|
|
2003
|
+ | WFull <- w_to = nilOL
|
|
|
2004
|
+ | WSub {truncInstr} <- w_to = pureTrunc truncInstr W32 freshReg r
|
|
|
2005
|
+ | otherwise = panicUnexpectedWidth
|
|
|
2006
|
+ pure (freshReg, instrs)
|
|
|
2007
|
+ SNeverClobbers
|
|
|
2008
|
+ -- noop
|
|
|
2009
|
+ | WFull <- w_to -> SNeverClobbered nilOL
|
|
|
2010
|
+ -- same register
|
|
|
2011
|
+ | WSub {truncInstr} <- w_to -> SNeverClobbered $ pureTrunc truncInstr W32 r r
|
|
|
2012
|
+ _ -> panicUnexpectedWidth
|
|
1946
|
2013
|
where
|
|
1947
|
|
- trunc instr = do
|
|
1948
|
|
- unitOL $ instr (OpReg W32 r) (OpReg W32 r)
|
|
|
2014
|
+ pureTrunc instr targetWidth destinationReg originReg
|
|
|
2015
|
+ = unitOL $ instr (OpReg targetWidth destinationReg) (OpReg targetWidth originReg)
|
|
|
2016
|
+ panicUnexpectedWidth = panic "truncateSubwordReg:unexpectedWidth"
|
|
1949
|
2017
|
|
|
1950
|
2018
|
-- -----------------------------------------------------------------------------
|
|
1951
|
2019
|
-- The 'Amode' type: Memory addressing modes passed up the tree.
|
| ... |
... |
@@ -3027,7 +3095,7 @@ data BlockInRange = InRange | NotInRange Target |
|
3027
|
3095
|
-- See Note [AArch64 far jumps]
|
|
3028
|
3096
|
makeFarBranches :: Platform -> LabelMap RawCmmStatics -> [NatBasicBlock Instr]
|
|
3029
|
3097
|
-> UniqDSM [NatBasicBlock Instr]
|
|
3030
|
|
-makeFarBranches {- only used when debugging -} _platform statics basic_blocks = do
|
|
|
3098
|
+makeFarBranches _platform statics basic_blocks = do
|
|
3031
|
3099
|
-- All offsets/positions are counted in multiples of 4 bytes (the size of AArch64 instructions)
|
|
3032
|
3100
|
-- That is an offset of 1 represents a 4-byte/one instruction offset.
|
|
3033
|
3101
|
let (func_size, lblMap) = foldl' calc_lbl_positions (0, mapEmpty) basic_blocks
|
| ... |
... |
@@ -3143,4 +3211,4 @@ makeFarBranches {- only used when debugging -} _platform statics basic_blocks = |
|
3143
|
3211
|
CBZ{} -> Just long_bz_jump_size
|
|
3144
|
3212
|
CBNZ{} -> Just long_bz_jump_size
|
|
3145
|
3213
|
BCOND{} -> Just long_bc_jump_size
|
|
3146
|
|
- _ -> Nothing |
|
|
3214
|
+ _ -> Nothing {- only used when debugging -} |