[project @ 2000-07-11 15:57:11 by simonmar]

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

diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs
index f6b7cb6..44fd702 100644 (file)
--- a/ghc/compiler/deSugar/DsForeign.lhs
+++ b/ghc/compiler/deSugar/DsForeign.lhs
@@ -14,18 +14,15 @@ import CoreSyn
 
 import DsCCall         ( dsCCall, mkCCall, boxResult, unboxArg )
 import DsMonad
-import DsUtils
 
 import HsSyn           ( ExtName(..), ForeignDecl(..), isDynamicExtName, ForKind(..) )
 import HsDecls         ( extNameStatic )
 import CallConv
 import TcHsSyn         ( TypecheckedForeignDecl )
 import CoreUtils       ( exprType, mkInlineMe )
-import DataCon         ( DataCon, dataConWrapId )
-import Id              ( Id, idType, idName, mkWildId, mkVanillaId, mkSysLocal,
+import Id              ( Id, idType, idName, mkVanillaId, mkSysLocal,
                          setInlinePragma )
 import IdInfo          ( neverInlinePrag )
-import MkId            ( mkWorkerId )
 import Literal         ( Literal(..) )
 import Module          ( Module, moduleUserString )
 import Name            ( mkGlobalName, nameModule, nameOccName, getOccString, 
@@ -37,10 +34,8 @@ import Type          ( unUsgTy, repType,
                          Type, mkFunTys, mkForAllTys, mkTyConApp,
                          mkTyVarTy, mkFunTy, splitAppTy, applyTy, funResultTy
                        )
-import PprType         ( {- instance Outputable Type -} )
-import PrimOp          ( PrimOp(..), CCall(..), CCallTarget(..) )
-import Var             ( TyVar )
-import TysPrim         ( realWorldStatePrimTy, addrPrimTy )
+import PrimOp          ( PrimOp(..), CCall(..), 
+                         CCallTarget(..), dynamicTarget )
 import TysWiredIn      ( unitTy, addrTy, stablePtrTyCon,
                          addrDataCon
                        )
@@ -48,7 +43,6 @@ import Unique         ( Uniquable(..), hasKey,
                          ioTyConKey, deRefStablePtrIdKey, returnIOIdKey, 
                          bindIOIdKey, makeStablePtrIdKey
                )
-import Maybes          ( maybeToBool )
 import Outputable
 \end{code}
 
@@ -141,14 +135,13 @@ dsFImport fn_id ty may_not_gc ext_name cconv
     mapAndUnzipDs unboxArg (map Var args)      `thenDs` \ (val_args, arg_wrappers) ->
     boxResult io_res_ty                                `thenDs` \ (ccall_result_ty, res_wrapper) ->
 
-    (case ext_name of
-       Dynamic       -> getUniqueDs `thenDs` \ u -> 
-                       returnDs (DynamicTarget u)
-       ExtName fs _  -> returnDs (StaticTarget fs))    `thenDs` \ lbl ->
-
     getUniqueDs                                                `thenDs` \ ccall_uniq ->
     getUniqueDs                                                `thenDs` \ work_uniq ->
     let
+       lbl = case ext_name of
+               Dynamic      -> dynamicTarget
+               ExtName fs _ -> StaticTarget fs
+
        -- Build the worker
        work_arg_ids  = [v | Var v <- val_args]         -- All guaranteed to be vars
        worker_ty     = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
@@ -171,7 +164,7 @@ Foreign labels
 dsFLabel :: Id -> ExtName -> DsM CoreBind
 dsFLabel nm ext_name = returnDs (NonRec nm fo_rhs)
   where
-   fo_rhs = mkConApp addrDataCon [mkLit (MachLitLit enm addrPrimTy)]
+   fo_rhs = mkConApp addrDataCon [mkLit (MachLabel enm)]
    enm    = extNameStatic ext_name
 \end{code}
 
@@ -358,7 +351,7 @@ dsFExportDynamic i ty mod_name ext_name cconv =
        -}
       adj_args      = [ mkIntLitInt (callConvToInt cconv)
                      , Var stbl_value
-                     , mkLit (MachLitLit (_PK_ fe_nm) addrPrimTy)
+                     , mkLit (MachLabel (_PK_ fe_nm))
                      ]
         -- name of external entry point providing these services.
        -- (probably in the RTS.)