[project @ 2004-08-13 13:04:50 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 22c8569..269274c 100644 (file)
--- a/ghc/compiler/deSugar/DsForeign.lhs
+++ b/ghc/compiler/deSugar/DsForeign.lhs
@@ -9,15 +9,17 @@ Expanding out @foreign import@ and @foreign export@ declarations.
 module DsForeign ( dsForeigns ) where
 
 #include "HsVersions.h"
+import TcRnMonad       -- temp
 
 import CoreSyn
 
 import DsCCall         ( dsCCall, mkFCall, boxResult, unboxArg, resultWrapper )
 import DsMonad
 
-import HsSyn           ( ForeignDecl(..), ForeignExport(..),
+import HsSyn           ( ForeignDecl(..), ForeignExport(..), LForeignDecl,
                          ForeignImport(..), CImportSpec(..) )
-import TcHsSyn         ( TypecheckedForeignDecl )
+import MachOp          ( machRepByteWidth )
+import SMRep           ( argMachRep, primRepToCgRep )
 import CoreUtils       ( exprType, mkInlineMe )
 import Id              ( Id, idType, idName, mkSysLocal, setInlinePragma )
 import Literal         ( Literal(..) )
@@ -34,17 +36,16 @@ import BasicTypes       ( Boxity(..) )
 import HscTypes                ( ForeignStubs(..) )
 import ForeignCall     ( ForeignCall(..), CCallSpec(..), 
                          Safety(..), playSafe,
-                         CExportSpec(..),
+                         CExportSpec(..), CLabelString,
                          CCallConv(..), ccallConvToInt,
                          ccallConvAttribute
                        )
-import CStrings                ( CLabelString )
 import TysWiredIn      ( unitTy, tupleTyCon )
 import TysPrim         ( addrPrimTy, mkStablePtrPrimTy, alphaTy )
-import PrimRep          ( getPrimRepSizeInBytes )
 import PrelNames       ( hasKey, ioTyConKey, stablePtrTyConName, newStablePtrName, bindIOName,
                          checkDotnetResName )
 import BasicTypes      ( Activation( NeverActive ) )
+import SrcLoc          ( Located(..), unLoc )
 import Outputable
 import Maybe           ( fromJust )
 import FastString
@@ -67,7 +68,7 @@ so we reuse the desugaring code in @DsCCall@ to deal with these.
 type Binding = (Id, CoreExpr)  -- No rec/nonrec structure;
                                -- the occurrence analyser will sort it all out
 
-dsForeigns :: [TypecheckedForeignDecl] 
+dsForeigns :: [LForeignDecl Id] 
           -> DsM (ForeignStubs, [Binding])
 dsForeigns [] 
   = returnDs (NoStubs, [])
@@ -75,9 +76,11 @@ dsForeigns fos
   = foldlDs combine (ForeignStubs empty empty [] [], []) fos
  where
   combine (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f) 
-         (ForeignImport id _ spec depr loc)
-    = dsFImport id spec                   `thenDs` \ (bs, h, c, mbhd) -> 
+         (L loc (ForeignImport id _ spec depr))
+    = traceIf (text "fi start" <+> ppr id)     `thenDs` \ _ ->
+      dsFImport (unLoc id) spec                   `thenDs` \ (bs, h, c, mbhd) -> 
       warnDepr depr loc                   `thenDs` \ _                ->
+      traceIf (text "fi end" <+> ppr id)       `thenDs` \ _ ->
       returnDs (ForeignStubs (h $$ acc_h)
                             (c $$ acc_c)
                             (addH mbhd acc_hdrs)
@@ -85,7 +88,7 @@ dsForeigns fos
                bs ++ acc_f)
 
   combine (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f) 
-         (ForeignExport id _ (CExport (CExportStatic ext_nm cconv)) depr loc)
+         (L loc (ForeignExport (L _ id) _ (CExport (CExportStatic ext_nm cconv)) depr))
     = dsFExport id (idType id) 
                ext_nm cconv False                 `thenDs` \(h, c, _) ->
       warnDepr depr loc                                   `thenDs` \_              ->
@@ -99,8 +102,8 @@ dsForeigns fos
 
   warnDepr False _   = returnDs ()
   warnDepr True  loc = dsWarn (loc, msg)
-   where
-    msg = ptext SLIT("foreign declaration uses deprecated non-standard syntax")
+     where
+       msg = ptext SLIT("foreign declaration uses deprecated non-standard syntax")
 \end{code}
 
 
@@ -234,8 +237,8 @@ dsFCall fn_id fcall no_hdrs
     topConDs                                        `thenDs` \ topCon -> 
     boxResult maybe_arg_ids augment topCon io_res_ty `thenDs` \ (ccall_result_ty, res_wrapper) ->
 
-    getUniqueDs                                        `thenDs` \ ccall_uniq ->
-    getUniqueDs                                        `thenDs` \ work_uniq ->
+    newUnique                                  `thenDs` \ ccall_uniq ->
+    newUnique                                  `thenDs` \ work_uniq ->
     let
        -- Build the worker
        worker_ty     = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
@@ -290,7 +293,7 @@ dsFExport :: Id                     -- Either the exported Id,
 dsFExport fn_id ty ext_name cconv isDyn
    = 
      let
-        (tvs,sans_foralls)             = tcSplitForAllTys ty
+        (_tvs,sans_foralls)            = tcSplitForAllTys ty
         (fe_arg_tys', orig_res_ty)     = tcSplitFunTys sans_foralls
        -- We must use tcSplits here, because we want to see 
        -- the (IO t) in the corner of the type!
@@ -386,7 +389,7 @@ dsFExportDynamic id cconv
        -- (probably in the RTS.) 
       adjustor  = FSLIT("createAdjustor")
       
-      sz_args   = sum (map (getPrimRepSizeInBytes . typePrimRep) stub_args)
+      sz_args   = sum (map (machRepByteWidth.argMachRep.primRepToCgRep.typePrimRep) stub_args)
       mb_sz_args = case cconv of
                      StdCallConv -> Just sz_args
                      _           -> Nothing