[GHC] #9038: Foreign calls don't make their arguments look strict

[GHC]

#9038: Foreign calls don't make their arguments look strict
------------------------------------+-------------------------------------
       Reporter:  tibbe             |             Owner:
           Type:  bug               |            Status:  new
       Priority:  normal            |         Milestone:
      Component:  Compiler          |           Version:  7.8.2
       Keywords:                    |  Operating System:  Unknown/Multiple
   Architecture:  Unknown/Multiple  |   Type of failure:  None/Unknown
     Difficulty:  Unknown           |         Test Case:
     Blocked By:                    |          Blocking:
Related Tickets:                    |
------------------------------------+-------------------------------------
 Here's a function that takes a `Double` which is always passed to a
 `foreign import` expecting a `Double#`. Since the value is always
 unpacked, I'd expect `add3` to be strict in the `Double` argument and
 thereby avoid some allocation.

 {{{
 add3
   :: Distribution
      -> Double
      -> Int64
      -> State# RealWorld
      -> (# State# RealWorld, () #)
 add3 =
   \ (distrib_a1uw :: Distribution)
     (val_a1ux :: Double)
     (n_a1uy :: Int64)
     (eta_X22 :: State# RealWorld) ->
     case myThreadId# eta_X22 of _ { (# ipv_i229, ipv1_i22a #) ->
     case threadStatus# ipv1_i22a ipv_i229
     of _ { (# ipv2_i22e, _, ipv4_i22g, _ #) ->
     case modInt# ipv4_i22g 8 of ww1_i1NM { __DEFAULT ->
     case distrib_a1uw
          `cast` (<NTCo:Distribution> :: Distribution ~# Array Stripe)
     of _ { Array ds2_i22q ->
     case indexArray# ds2_i22q ww1_i1NM of _ { (# ipv6_i1Nz #) ->
     case ipv6_i1Nz
     of _ { Stripe ipv7_s22v ipv8_s22w ipv9_s22x ipv10_s22y ->
     case {__pkg_ccall main hs_lock Addr#
                           -> State# RealWorld -> (# State# RealWorld
 #)}_i20J
            ipv9_s22x ipv2_i22e
     of _ { (# ds4_i20P #) ->
     case touch# ipv10_s22y ds4_i20P of s'_i20R { __DEFAULT ->
     case val_a1ux of _ { D# ds6_d1D8 ->
     case n_a1uy of _ { I64# ds8_d1Da ->
     case {__pkg_ccall main hs_distrib_add_n Addr#
                                    -> Double# -> Int# -> State# RealWorld
 -> (# State# RealWorld #)}_d1Dd
            ipv7_s22v ds6_d1D8 ds8_d1Da s'_i20R
     of _ { (# ds9_d1Db #) ->
     case {__pkg_ccall main hs_unlock Addr#
                             -> State# RealWorld -> (# State# RealWorld
 #)}_i20m
            ipv9_s22x ds9_d1Db
     of _ { (# ds10_i20s #) ->
     case touch# ipv10_s22y ds10_i20s of s'1_i20u { __DEFAULT ->
     case touch# ipv8_s22w s'1_i20u of s'2_i1YT { __DEFAULT ->
     (# s'2_i1YT, () #)
     }
     }
     }
     }
     }
     }
     }
     }
     }
     }
     }
     }
     }
     }
 }}}

--
Ticket URL: <http://ghc.haskell.org/trac/ghc/ticket/9038>
GHC <http://www.haskell.org/ghc/>
The Glasgow Haskell Compiler