From e513c1cc1de895fed5796d16cb67525f4b581b2a Mon Sep 17 00:00:00 2001
From: Samuel Bronson <naesten@gmail.com>
Date: Wed, 1 Nov 2006 00:36:49 +0000
Subject: [PATCH] Get External Core (-fext-core) working with readline Had to
 add support for dynamic C calls and for foreign labels
 (Addr# constants). Actually I only did the printing side --
 parsing is not done yet. But at least now you can build the
 libraries with -fext-core.

I also got the function arrow to print out properly again (it was
printing fully-qualified and z-coded!)

I also added a field for calling convention name to the External
data constructor in ExternalCore.Exp (for static C calls).

I'm not exactly sure where to document all of this, so I haven't done
that, though I did comment the code a bit.
---
 compiler/coreSyn/ExternalCore.lhs    |    8 +++++---
 compiler/coreSyn/MkExternalCore.lhs  |   11 ++++++++---
 compiler/coreSyn/PprExternalCore.lhs |    4 +++-
 3 files changed, 16 insertions(+), 7 deletions(-)

diff --git a/compiler/coreSyn/ExternalCore.lhs b/compiler/coreSyn/ExternalCore.lhs
index c5035e2..89b2712 100644
--- a/compiler/coreSyn/ExternalCore.lhs
+++ b/compiler/coreSyn/ExternalCore.lhs
@@ -34,7 +34,9 @@ data Exp
   | Case Exp Vbind Ty [Alt] {- non-empty list -}
   | Cast Exp Ty
   | Note String Exp
-  | External String Ty
+  | External String String Ty {- target name, convention, and type -} 
+  | DynExternal String Ty {- convention and type (incl. Addr# of target as first arg) -} 
+  | Label String
 
 data Bind 
   = Vb Vbind
@@ -78,10 +80,10 @@ type Qual t = (Mname,t)
 
 type Id = String
 
-primMname = "GHCziPrim"
+primMname = "base:GHC.Prim"
 
 tcArrow :: Qual Tcon
-tcArrow = (primMname, "ZLzmzgZR")
+tcArrow = (primMname, "(->)")
 
 \end{code}
 
diff --git a/compiler/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs
index 467cff5..150ae16 100644
--- a/compiler/coreSyn/MkExternalCore.lhs
+++ b/compiler/coreSyn/MkExternalCore.lhs
@@ -105,10 +105,15 @@ make_exp (Var v) =
   case globalIdDetails v of
      -- 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 (idType v))
-    FCallId _ -> error "MkExternalCore died: can't handle non-static-C foreign call"
+    FCallId (CCall (CCallSpec (StaticTarget nm) callconv _)) 
+        -> C.External (unpackFS nm) (showSDoc (ppr callconv)) (make_ty (idType v))
+    FCallId (CCall (CCallSpec DynamicTarget     callconv _)) 
+        -> C.DynExternal            (showSDoc (ppr callconv)) (make_ty (idType v))
+    FCallId _ 
+        -> pprPanic "MkExternalCore died: can't handle non-{static,dynamic}-C foreign call"
+                    (ppr v)
     _ -> C.Var (make_var_qid (Var.varName v))
-make_exp (Lit (l@(MachLabel s _))) = error "MkExternalCore died: can't handle \"foreign label\" declarations"
+make_exp (Lit (l@(MachLabel s _))) = C.Label (unpackFS s)
 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)
diff --git a/compiler/coreSyn/PprExternalCore.lhs b/compiler/coreSyn/PprExternalCore.lhs
index fe29131..502c268 100644
--- a/compiler/coreSyn/PprExternalCore.lhs
+++ b/compiler/coreSyn/PprExternalCore.lhs
@@ -134,7 +134,9 @@ pexp (Case e vb ty alts) = sep [text "%case" <+> parens (paty ty) <+> paexp e,
 			$$ (indent (braces (vcat (punctuate (char ';') (map palt alts)))))
 pexp (Cast e co) = (text "%cast" <+> pexp e) $$ paty co
 pexp (Note s e) = (text "%note" <+> pstring s) $$ pexp e
-pexp (External n t) = (text "%external" <+> pstring n) $$ paty t
+pexp (External n cc t) = (text "%external" <+> text cc <+> pstring n) $$ paty t
+pexp (DynExternal cc t) = (text "%dynexternal" <+> text cc) $$ paty t
+pexp (Label n) = (text "%label" <+> pstring n)
 pexp e = pfexp e
 
 
-- 
1.7.10.4