Andreas Klebinger pushed to branch wip/andreask/arm-ffi at Glasgow Haskell Compiler / GHC

Commits:

5 changed files:

Changes:

  • compiler/GHC/Cmm/Expr.hs
    ... ... @@ -443,6 +443,11 @@ pprExpr platform e
    443 443 
             CmmLit lit -> pprLit platform lit
    444 444 
             _other     -> pprExpr1 platform e
    445 445
    446 
    +-- `exp` usually, but (expr[width]) with -dppr-debug
    447 
    +withDebugWidth :: Width -> SDoc -> SDoc
    448 
    +withDebugWidth w exp =
    449 
    +  ifPprDebug (parens (exp <> brackets (ppr w))) exp
    450 
    +
    446 451 
     -- Here's the precedence table from GHC.Cmm.Parser:
    447 452 
     -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
    448 453 
     -- %left '|'
    ... ... @@ -465,15 +470,17 @@ pprExpr1 platform e = pprExpr7 platform e
    465 470
    466 471 
     infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc
    467 472
    468 
    -infixMachOp1 (MO_Eq     _) = Just (text "==")
    469 
    -infixMachOp1 (MO_Ne     _) = Just (text "!=")
    470 
    -infixMachOp1 (MO_Shl    _) = Just (text "<<")
    471 
    -infixMachOp1 (MO_U_Shr  _) = Just (text ">>")
    472 
    -infixMachOp1 (MO_U_Ge   _) = Just (text ">=")
    473 
    -infixMachOp1 (MO_U_Le   _) = Just (text "<=")
    474 
    -infixMachOp1 (MO_U_Gt   _) = Just (char '>')
    475 
    -infixMachOp1 (MO_U_Lt   _) = Just (char '<')
    476 
    -infixMachOp1 _             = Nothing
    473 
    +infixMachOp1 mop = case mop of
    474 
    +    (MO_Eq     w) -> Just $ withDebugWidth w (text "==")
    475 
    +    (MO_Ne     w) -> Just $ withDebugWidth w (text "!=")
    476 
    +    (MO_Shl    w) -> Just $ withDebugWidth w (text "<<")
    477 
    +    (MO_U_Shr  w) -> Just $ withDebugWidth w (text ">>")
    478 
    +    (MO_U_Ge   w) -> Just $ withDebugWidth w (text ">=")
    479 
    +    (MO_U_Le   w) -> Just $ withDebugWidth w (text "<=")
    480 
    +    (MO_U_Gt   w) -> Just $ withDebugWidth w (char '>')
    481 
    +    (MO_U_Lt   w) -> Just $ withDebugWidth w (char '<')
    482 
    +    _             -> Nothing
    483 
    +    where
    477 484
    478 485 
     -- %left '-' '+'
    479 486 
     pprExpr7 platform (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0
    ... ... @@ -483,8 +490,8 @@ pprExpr7 platform (CmmMachOp op [x,y])
    483 490 
        = pprExpr7 platform x <+> doc <+> pprExpr8 platform y
    484 491 
     pprExpr7 platform e = pprExpr8 platform e
    485 492
    486 
    -infixMachOp7 (MO_Add _)  = Just (char '+')
    487 
    -infixMachOp7 (MO_Sub _)  = Just (char '-')
    493 
    +infixMachOp7 (MO_Add w)  = Just $ withDebugWidth w (char '+')
    494 
    +infixMachOp7 (MO_Sub w)  = Just $ withDebugWidth w (char '-')
    488 495 
     infixMachOp7 _           = Nothing
    489 496
    490 497 
     -- %left '/' '*' '%'
    ... ... @@ -493,9 +500,9 @@ pprExpr8 platform (CmmMachOp op [x,y])
    493 500 
        = pprExpr8 platform x <+> doc <+> pprExpr9 platform y
    494 501 
     pprExpr8 platform e = pprExpr9 platform e
    495 502
    496 
    -infixMachOp8 (MO_U_Quot _) = Just (char '/')
    497 
    -infixMachOp8 (MO_Mul _)    = Just (char '*')
    498 
    -infixMachOp8 (MO_U_Rem _)  = Just (char '%')
    503 
    +infixMachOp8 (MO_U_Quot w) = Just $ withDebugWidth w (char '/')
    504 
    +infixMachOp8 (MO_Mul w)    = Just $ withDebugWidth w (char '*')
    505 
    +infixMachOp8 (MO_U_Rem w)  = Just $ withDebugWidth w (char '%')
    499 506 
     infixMachOp8 _             = Nothing
    500 507
    501 508 
     pprExpr9 :: Platform -> CmmExpr -> SDoc

  • compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
    ... ... @@ -2898,6 +2898,7 @@ genCCall target dest_regs arg_regs = do
    2898 2898
    2899 2899 
         passArguments _ _ _ _ _ _ _ = pprPanic "passArguments" (text "invalid state")
    2900 2900
    2901 
    +    -- | readResults gpArgs fpArgs dest_regs reg_acc code_acc
    2901 2902 
         readResults :: [Reg] -> [Reg] -> [LocalReg] -> [Reg]-> InstrBlock -> NatM (InstrBlock)
    2902 2903 
         readResults _ _ [] _ accumCode = return accumCode
    2903 2904 
         readResults [] _ _ _ _ = do

  • testsuite/tests/codeGen/should_run/T27430.hs
    1 
    +{-# LANGUAGE MagicHash #-}
    2 
    +{-# OPTIONS_GHC -dno-typeable-binds -ddump-to-file -dsuppress-ticks -dsuppress-timestamps -ddump-stg-from-core -ddump-stg-final -ddump-cmm -ddump-cmm-raw -ddump-asm #-}
    3 
    +
    4 
    +import GHC.Exts
    5 
    +import Data.Word (Word64)
    6 
    +import GHC.Word (Word8(..))
    7 
    +import System.Environment (getArgs)
    8 
    +
    9 
    +foreign import ccall unsafe "u64_to_u8" u64_to_u8 :: Word64 -> Word8
    10 
    +foreign import ccall unsafe "u64_to_u16" u64_to_u16 :: Word64 -> Word8
    11 
    +foreign import ccall unsafe "u64_to_u32" u64_to_u32 :: Word64 -> Word8
    12 
    +
    13 
    +x :: Word64
    14 
    +x = 5
    15 
    +
    16 
    +y :: Word64
    17 
    +y = 65541
    18 
    +
    19 
    +eq8 :: Word8 -> Word8 -> Int
    20 
    +eq8 (W8# a) (W8# b) = I# (eqWord8# a b)
    21 
    +
    22 
    +main :: IO ()
    23 
    +main = print (eq8 (u64_to_u8 x) (u64_to_u8 y))

  • testsuite/tests/codeGen/should_run/T27430_c.c
    1 
    +#include <stdint.h>
    2 
    +
    3 
    +uint8_t u64_to_u8(uint64_t v) { return (uint8_t)v; }
    4 
    +uint8_t u64_to_u16(uint64_t v) { return (uint16_t)v; }
    5 
    +uint8_t u64_to_u32(uint64_t v) { return (uint32_t)v; }

  • testsuite/tests/ffi/should_run/all.T
    ... ... @@ -264,3 +264,5 @@ test('T24598', req_cmm, compile_and_run, ['T24598_cmm.cmm'])
    264 264 
     test('T24598b', req_cmm, compile_and_run, ['T24598b_cmm.cmm'])
    265 265 
     test('T24598c', req_cmm, compile_and_run, ['T24598c_cmm.cmm'])
    266 266 
     test('T24818', [req_cmm, req_c], compile_and_run, ['-XUnliftedFFITypes T24818_cmm.cmm T24818_c.c'])
    267 
    +
    268 
    +test('T27430', [req_c], compile_and_run, ['T27430_c.c'])

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