Add the notion of "constructor-like" Ids for rule-matching

[ghc-hetmet.git] / compiler / deSugar / DsForeign.lhs

diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs
index 007edb9..7071ab7 100644 (file)
--- a/compiler/deSugar/DsForeign.lhs
+++ b/compiler/deSugar/DsForeign.lhs
@@ -19,7 +19,6 @@ import DsMonad
 import HsSyn
 import DataCon
 import CoreUtils
-import CoreUnfold
 import Id
 import Literal
 import Module
@@ -143,10 +142,15 @@ dsCImport :: Id
          -> DsM ([Binding], SDoc, SDoc)
 dsCImport id (CLabel cid) cconv _ = do
    let ty = idType id
+       fod = case splitTyConApp_maybe (repType ty) of
+             Just (tycon, _)
+              | tyConUnique tycon == funPtrTyConKey ->
+                 IsFunction
+             _ -> IsData
    (resTy, foRhs) <- resultWrapper ty
    ASSERT(fromJust resTy `coreEqType` addrPrimTy)    -- typechecker ensures this
     let
-        rhs = foRhs (Lit (MachLabel cid stdcall_info))
+        rhs = foRhs (Lit (MachLabel cid stdcall_info fod))
         stdcall_info = fun_type_arg_stdcall_info cconv ty
     in
     return ([(id, rhs)], empty, empty)
@@ -231,10 +235,9 @@ dsFCall fn_id fcall = do
         -- Build the wrapper
         work_app     = mkApps (mkVarApps (Var work_id) tvs) val_args
         wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
-        wrap_rhs     = mkLams (tvs ++ args) wrapper_body
-        fn_id_w_inl  = fn_id `setIdUnfolding` mkInlineRule wrap_rhs (length args)
+        wrap_rhs     = mkInlineMe (mkLams (tvs ++ args) wrapper_body)
     
-    return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs)], empty, empty)
+    return ([(work_id, work_rhs), (fn_id, wrap_rhs)], empty, empty)
 \end{code}
 
 
@@ -357,7 +360,7 @@ dsFExportDynamic id cconv = do
          -}
         adj_args      = [ mkIntLitInt (ccallConvToInt cconv)
                         , Var stbl_value
-                        , Lit (MachLabel fe_nm mb_sz_args)
+                        , Lit (MachLabel fe_nm mb_sz_args IsFunction)
                         , Lit (mkMachString typestring)
                         ]
           -- name of external entry point providing these services.
@@ -384,7 +387,7 @@ dsFExportDynamic id cconv = do
                         , Lam stbl_value ccall_adj
                         ]
 
-        fed = (id `setInlinePragma` NeverActive, io_app)
+        fed = (id `setInlineActivation` NeverActive, io_app)
                -- Never inline the f.e.d. function, because the litlit
                -- might not be in scope in other modules.