[project @ 2002-10-24 16:54:19 by simonpj]

[ghc-hetmet.git] / ghc / compiler / coreSyn / MkExternalCore.lhs

diff --git a/ghc/compiler/coreSyn/MkExternalCore.lhs b/ghc/compiler/coreSyn/MkExternalCore.lhs
index b8e955c..6bb2f30 100644 (file)
--- a/ghc/compiler/coreSyn/MkExternalCore.lhs
+++ b/ghc/compiler/coreSyn/MkExternalCore.lhs
@@ -29,29 +29,29 @@ import ForeignCall
 import PprExternalCore 
 import CmdLineOpts
 import IO
+import FastString
 
-emitExternalCore :: DynFlags -> ModIface -> ModDetails -> IO ()
-emitExternalCore dflags iface details 
+emitExternalCore :: DynFlags -> ModGuts -> IO ()
+emitExternalCore dflags mod_impl
  | opt_EmitExternalCore 
  = (do handle <- openFile corename WriteMode
-       hPutStr handle (show (mkExternalCore iface details))      
+       hPutStr handle (show (mkExternalCore mod_impl))      
        hClose handle)
    `catch` (\err -> pprPanic "Failed to open or write external core output file" 
                             (text corename))
    where corename = extCoreName dflags
-emitExternalCore _ _ _ 
+emitExternalCore _ _
  | otherwise
  = return ()
 
 
-mkExternalCore :: ModIface -> ModDetails -> C.Module
-mkExternalCore (ModIface {mi_module=mi_module,mi_exports=mi_exports}) 
-              (ModDetails {md_types=md_types,md_binds=md_binds}) =
-    C.Module mname tdefs vdefs
+mkExternalCore :: ModGuts -> C.Module
+mkExternalCore (ModGuts {mg_module=this_mod, mg_types = type_env, mg_binds = binds})
+  = C.Module mname tdefs vdefs
   where
-    mname = make_mid mi_module
-    tdefs = foldr collect_tdefs [] (typeEnvTyCons md_types)
-    vdefs = map make_vdef md_binds
+    mname = make_mid this_mod
+    tdefs = foldr collect_tdefs [] (typeEnvTyCons type_env)
+    vdefs = map make_vdef binds
 
 collect_tdefs :: TyCon -> [C.Tdef] -> [C.Tdef]
 collect_tdefs tcon tdefs 
@@ -72,7 +72,7 @@ collect_tdefs _ tdefs = tdefs
 make_cdef :: DataCon -> C.Cdef
 make_cdef dcon =  C.Constr dcon_name existentials tys
   where 
-    dcon_name    = make_con_qid (idName (dataConWorkId dcon))
+    dcon_name    = make_con_qid (dataConName dcon)
     existentials = map make_tbind ex_tyvars
     ex_tyvars    = dataConExistentialTyVars dcon
     tys         = map make_ty (dataConRepArgTys dcon)
@@ -93,11 +93,12 @@ make_vdef b =
 make_exp :: CoreExpr -> C.Exp
 make_exp (Var v) =  
   case globalIdDetails v of
-    DataConId _ -> C.Dcon (make_con_qid (Var.varName v))
-    FCallId (CCall (CCallSpec (StaticTarget nm) _ _)) -> C.External (_UNPK_ nm) (make_ty (varType v))
+     -- a DataConId represents the Id of a worker, which is a varName. -- sof 4/02
+--    DataConId _ -> C.Dcon (make_con_qid (Var.varName v))
+    FCallId (CCall (CCallSpec (StaticTarget nm) _ _)) -> C.External (unpackFS nm) (make_ty (varType v))
     FCallId _ -> error "MkExternalCore died: can't handle non-static-C foreign call"
     _ -> C.Var (make_var_qid (Var.varName v))
-make_exp (Lit (l@(MachLabel s))) = C.External (_UNPK_ s) (make_ty (literalType l))
+make_exp (Lit (l@(MachLabel s))) = C.External (unpackFS s) (make_ty (literalType l))
 make_exp (Lit l) = C.Lit (make_lit l)
 make_exp (App e (Type t)) = C.Appt (make_exp e) (make_ty t)
 make_exp (App e1 e2) = C.App (make_exp e1) (make_exp e2)
@@ -113,7 +114,10 @@ make_exp _ = error "MkExternalCore died: make_exp"
 
 make_alt :: CoreAlt -> C.Alt
 make_alt (DataAlt dcon, vs, e) = 
-    C.Acon (make_con_qid (idName (dataConWorkId dcon))) (map make_tbind tbs) (map make_vbind vbs) (make_exp e)
+    C.Acon (make_con_qid (dataConName dcon))
+           (map make_tbind tbs)
+           (map make_vbind vbs)
+          (make_exp e)    
        where (tbs,vbs) = span isTyVar vs
 make_alt (LitAlt l,_,e) = C.Alit (make_lit l) (make_exp e)
 make_alt (DEFAULT,[],e) = C.Adefault (make_exp e)
@@ -123,7 +127,7 @@ make_lit l =
   case l of
     MachChar i | i <= 0xff -> C.Lchar (chr i) t
     MachChar i | otherwise -> C.Lint (toEnum i) t
-    MachStr s -> C.Lstring (_UNPK_ s) t
+    MachStr s -> C.Lstring (unpackFS s) t
     MachAddr i -> C.Lint i t  
     MachInt i -> C.Lint i t
     MachInt64 i -> C.Lint i t
@@ -157,6 +161,9 @@ make_kind _ = error "MkExternalCore died: make_kind"
 {- Use encoded strings.
    Also, adjust casing to work around some badly-chosen internal names. -}
 make_id :: Bool -> Name -> C.Id
+make_id is_var nm = (occNameString . nameOccName) nm
+
+{-     SIMON thinks this stuff isn't necessary
 make_id is_var nm = 
   case n of
     'Z':cs | is_var -> 'z':cs 
@@ -165,6 +172,7 @@ make_id is_var nm =
     c:cs | isLower c && (not is_var) -> 'Z':'d':n
     _ -> n
   where n = (occNameString . nameOccName) nm
+-}
 
 make_var_id :: Name -> C.Id
 make_var_id = make_id True