Fix external core syntax (though not full compilation)
[ghc.git] / compiler / coreSyn / MkExternalCore.lhs
1
2 % (c) The University of Glasgow 2001-2006
3 %
4 \begin{code}
5
6 module MkExternalCore (
7         emitExternalCore
8 ) where
9
10 #include "HsVersions.h"
11
12 import qualified ExternalCore as C
13 import Char
14 import Module
15 import CoreSyn
16 import HscTypes 
17 import TyCon
18 import TypeRep
19 import Type
20 import PprExternalCore  -- Instances
21 import DataCon
22 import CoreSyn
23 import Coercion
24 import Var
25 import IdInfo
26 import Literal
27 import Name
28 import NameSet
29 import UniqSet
30 import Outputable
31 import ForeignCall
32 import DynFlags
33 import StaticFlags
34 import IO
35 import FastString
36
37 emitExternalCore :: DynFlags -> NameSet -> CgGuts -> IO ()
38 emitExternalCore dflags exports cg_guts
39  | opt_EmitExternalCore 
40  = (do handle <- openFile corename WriteMode
41        hPutStrLn handle (show (mkExternalCore exports cg_guts))      
42        hClose handle)
43    `catch` (\err -> pprPanic "Failed to open or write external core output file" 
44                              (text corename))
45    where corename = extCoreName dflags
46 emitExternalCore _ _ _
47  | otherwise
48  = return ()
49
50
51 mkExternalCore :: NameSet -> CgGuts -> C.Module
52 -- The ModGuts has been tidied, but the implicit bindings have
53 -- not been injected, so we have to add them manually here
54 -- We don't include the strange data-con *workers* because they are
55 -- implicit in the data type declaration itself
56 mkExternalCore exports (CgGuts {cg_module=this_mod, cg_tycons = tycons, cg_binds = binds})
57   = C.Module mname tdefs (map (make_vdef exports) binds)
58   where
59     mname  = make_mid this_mod
60     tdefs  = foldr collect_tdefs [] tycons
61
62 collect_tdefs :: TyCon -> [C.Tdef] -> [C.Tdef]
63 collect_tdefs tcon tdefs 
64   | isAlgTyCon tcon = tdef: tdefs
65   where
66     tdef | isNewTyCon tcon = 
67                 C.Newtype (make_con_qid (tyConName tcon)) (map make_tbind tyvars) repclause 
68 -- 20060420 GHC handles empty data types just fine. ExtCore should too! jds
69 --         | null (tyConDataCons tcon) = error "MkExternalCore died: can't handle datatype declarations with no data constructors"
70          | otherwise = 
71                 C.Data (make_con_qid (tyConName tcon)) (map make_tbind tyvars) (map make_cdef (tyConDataCons tcon)) 
72          where repclause | isRecursiveTyCon tcon || isOpenTyCon tcon= Nothing
73                          | otherwise = Just (make_ty rep)
74                                            where (_, rep) = newTyConRep tcon
75     tyvars = tyConTyVars tcon
76
77 collect_tdefs _ tdefs = tdefs
78
79
80 make_cdef :: DataCon -> C.Cdef
81 make_cdef dcon =  C.Constr dcon_name existentials tys
82   where 
83     dcon_name    = make_var_id (dataConName dcon)
84     existentials = map make_tbind ex_tyvars
85     ex_tyvars    = dataConExTyVars dcon
86     tys          = map make_ty (dataConRepArgTys dcon)
87
88 make_tbind :: TyVar -> C.Tbind
89 make_tbind tv = (make_var_id (tyVarName tv), make_kind (tyVarKind tv))
90     
91 make_vbind :: Var -> C.Vbind
92 make_vbind v = (make_var_id  (Var.varName v), make_ty (idType v))
93
94 make_vdef :: NameSet -> CoreBind -> C.Vdefg
95 make_vdef exports b = 
96   case b of
97     NonRec v e -> C.Nonrec (f (v,e))
98     Rec ves -> C.Rec (map f ves)
99   where
100   f (v,e) = (local, make_var_id (Var.varName v), make_ty (idType v),make_exp e)
101         where local = not $ elementOfUniqSet (Var.varName v) exports
102         -- Top level bindings are unqualified now
103
104 make_exp :: CoreExpr -> C.Exp
105 make_exp (Var v) =  
106   case globalIdDetails v of
107      -- a DataConId represents the Id of a worker, which is a varName. -- sof 4/02
108 --    DataConId _ -> C.Dcon (make_con_qid (Var.varName v))
109     FCallId (CCall (CCallSpec (StaticTarget nm) callconv _)) 
110         -> C.External (unpackFS nm) (showSDoc (ppr callconv)) (make_ty (idType v))
111     FCallId (CCall (CCallSpec DynamicTarget     callconv _)) 
112         -> C.DynExternal            (showSDoc (ppr callconv)) (make_ty (idType v))
113     FCallId _ 
114         -> pprPanic "MkExternalCore died: can't handle non-{static,dynamic}-C foreign call"
115                     (ppr v)
116     _ -> C.Var (make_var_qid (Var.varName v))
117 make_exp (Lit (l@(MachLabel s _))) = C.Label (unpackFS s)
118 make_exp (Lit l) = C.Lit (make_lit l)
119 make_exp (App e (Type t)) = C.Appt (make_exp e) (make_ty t)
120 make_exp (App e1 e2) = C.App (make_exp e1) (make_exp e2)
121 make_exp (Lam v e) | isTyVar v = C.Lam (C.Tb (make_tbind v)) (make_exp e)
122 make_exp (Lam v e) | otherwise = C.Lam (C.Vb (make_vbind v)) (make_exp e)
123 make_exp (Cast e co) = C.Cast (make_exp e) (make_ty co)
124 make_exp (Let b e) = C.Let (make_vdef emptyNameSet b) (make_exp e)
125 -- gaw 2004
126 make_exp (Case e v ty alts) = C.Case (make_exp e) (make_vbind v) (make_ty ty) (map make_alt alts)
127 make_exp (Note (SCC cc) e) = C.Note "SCC"  (make_exp e) -- temporary
128 make_exp (Note (CoreNote s) e) = C.Note s (make_exp e)  -- hdaume: core annotations
129 make_exp (Note InlineMe e) = C.Note "InlineMe" (make_exp e)
130 make_exp _ = error "MkExternalCore died: make_exp"
131
132 make_alt :: CoreAlt -> C.Alt
133 make_alt (DataAlt dcon, vs, e) = 
134     C.Acon (make_con_qid (dataConName dcon))
135            (map make_tbind tbs)
136            (map make_vbind vbs)
137            (make_exp e)    
138         where (tbs,vbs) = span isTyVar vs
139 make_alt (LitAlt l,_,e) = C.Alit (make_lit l) (make_exp e)
140 make_alt (DEFAULT,[],e) = C.Adefault (make_exp e)
141
142 make_lit :: Literal -> C.Lit
143 make_lit l = 
144   case l of
145     MachChar i -> C.Lchar i t
146     MachStr s -> C.Lstring (unpackFS s) t
147     MachNullAddr -> C.Lint 0 t
148     MachInt i -> C.Lint i t
149     MachInt64 i -> C.Lint i t
150     MachWord i -> C.Lint i t
151     MachWord64 i -> C.Lint i t
152     MachFloat r -> C.Lrational r t
153     MachDouble r -> C.Lrational r t
154     _ -> error "MkExternalCore died: make_lit"
155   where 
156     t = make_ty (literalType l)
157
158 make_ty :: Type -> C.Ty
159 make_ty (TyVarTy tv)             = C.Tvar (make_var_id (tyVarName tv))
160 make_ty (AppTy t1 t2)            = C.Tapp (make_ty t1) (make_ty t2)
161 make_ty (FunTy t1 t2)            = make_ty (TyConApp funTyCon [t1,t2])
162 make_ty (ForAllTy tv t)          = C.Tforall (make_tbind tv) (make_ty t)
163 make_ty (TyConApp tc ts)         = foldl C.Tapp (C.Tcon (make_con_qid (tyConName tc))) 
164                                          (map make_ty ts)
165 -- Newtypes are treated just like any other type constructor; not expanded
166 -- Reason: predTypeRep does substitution and, while substitution deals
167 --         correctly with name capture, it's only correct if you see the uniques!
168 --         If you just see occurrence names, name capture may occur.
169 -- Example: newtype A a = A (forall b. b -> a)
170 --          test :: forall q b. q -> A b
171 --          test _ = undefined
172 --      Here the 'a' gets substituted by 'b', which is captured.
173 -- Another solution would be to expand newtypes before tidying; but that would
174 -- expose the representation in interface files, which definitely isn't right.
175 -- Maybe CoreTidy should know whether to expand newtypes or not?
176
177 make_ty (PredTy p)      = make_ty (predTypeRep p)
178 make_ty (NoteTy _ t)    = make_ty t
179
180
181
182 make_kind :: Kind -> C.Kind
183 make_kind (PredTy p) | isEqPred p = C.Keq (make_ty t1) (make_ty t2)
184     where (t1, t2) = getEqPredTys p
185 make_kind (FunTy k1 k2)  = C.Karrow (make_kind k1) (make_kind k2)
186 make_kind k
187   | isLiftedTypeKind k   = C.Klifted
188   | isUnliftedTypeKind k = C.Kunlifted
189   | isOpenTypeKind k     = C.Kopen
190 make_kind _ = error "MkExternalCore died: make_kind"
191
192 {- Id generation. -}
193
194 {- Use encoded strings.
195    Also, adjust casing to work around some badly-chosen internal names. -}
196 make_id :: Bool -> Name -> C.Id
197 make_id is_var nm = (occNameString . nameOccName) nm
198
199 {-      SIMON thinks this stuff isn't necessary
200 make_id is_var nm = 
201   case n of
202     'Z':cs | is_var -> 'z':cs 
203     'z':cs | not is_var -> 'Z':cs 
204     c:cs | isUpper c && is_var -> 'z':'d':n
205     c:cs | isLower c && (not is_var) -> 'Z':'d':n
206     _ -> n
207   where n = (occNameString . nameOccName) nm
208 -}
209
210 make_var_id :: Name -> C.Id
211 make_var_id = make_id True
212
213 make_mid :: Module -> C.Id
214 make_mid = showSDoc . pprModule
215
216 make_qid :: Bool -> Name -> C.Qual C.Id
217 make_qid is_var n = (mname,make_id is_var n)
218     where mname = 
219            case nameModule_maybe n of
220             Just m -> make_mid m
221             Nothing -> "" 
222
223 make_var_qid :: Name -> C.Qual C.Id
224 make_var_qid = make_qid True
225
226 make_con_qid :: Name -> C.Qual C.Id
227 make_con_qid = make_qid False
228
229 \end{code}
230
231
232
233