[project @ 2001-06-25 08:09:57 by simonpj]
[ghc-hetmet.git] / ghc / compiler / coreSyn / MkExternalCore.lhs
1 %
2 % (c) The University of Glasgow 2001
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 Ratio
15 import Module
16 import CoreSyn
17 import HscTypes 
18 import TyCon
19 import TypeRep
20 import Type
21 import DataCon
22 import CoreSyn
23 import Var
24 import IdInfo
25 import NameEnv
26 import Literal
27 import Name
28 import CostCentre
29 import Outputable
30 import PrimOp
31 import Class
32 import ForeignCall
33 import PprExternalCore  
34 import CmdLineOpts
35 import IO
36
37 emitExternalCore :: DynFlags -> ModIface -> ModDetails -> IO ()
38 emitExternalCore dflags iface details 
39  | opt_EmitExternalCore 
40  = (do handle <- openFile corename WriteMode
41        hPutStr handle (show (mkExternalCore iface details))      
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 :: ModIface -> ModDetails -> C.Module
52 mkExternalCore (ModIface {mi_module=mi_module,mi_exports=mi_exports}) 
53                (ModDetails {md_types=md_types,md_binds=md_binds}) =
54     C.Module mname {- exports -} tdefs vdefs
55   where
56     mname = make_mid mi_module
57 {-  exports = foldr (collect_exports md_types) ([],[],[]) all_avails 
58     all_avails = concat (map snd (filter ((== moduleName mi_module) . fst) mi_exports))
59 -}
60     tdefs = foldr collect_tdefs [] (typeEnvTyCons md_types)
61     vdefs = map make_vdef md_binds
62
63 {-
64 collect_exports :: TypeEnv -> AvailInfo -> ([C.Tcon],[C.Dcon],[C.Var]) -> ([C.Tcon],[C.Dcon],[C.Var])
65 collect_exports tyenv (Avail n) (tcons,dcons,vars) = (tcons,dcons,make_var_id n:vars)       
66 collect_exports tyenv (AvailTC n ns) (tcons,dcons,vars) = 
67   case lookupNameEnv_NF tyenv n of
68      ATyCon tc | isAlgTyCon tc -> 
69          (tcon ++ tcons,workers ++ dcons,wrappers ++ vars)
70          where 
71            tcon = if elem n ns then [make_con_id n] else []
72            workers = if isNewTyCon tc then []
73                      else map  (make_con_id . idName . dataConId) exported_dcs
74            exported_dcs = filter (\dc -> elem ((idName . dataConWrapId) dc) ns') dcs
75            dcs = tyConDataConsIfAvailable tc
76            wrappers = map make_var_id ns'
77            ns' = filter (\n' -> n' /= n && not (elem n' recordSels)) ns
78            recordSels = map idName (tyConSelIds tc)
79      AClass cl ->  {- maybe a little too free about exports -}
80         (tcon : tcons,workers ++ dcons,wrappers ++ vars)
81         where 
82           tcon = make_con_id (tyConName tc)
83           workers = if isNewTyCon tc then []
84                     else map (make_con_id . idName . dataConId) dcs 
85           wrappers = map (make_var_id . idName . dataConWrapId) dcs
86           dcs = tyConDataConsIfAvailable tc
87           tc = classTyCon cl
88      _ -> (tcons,dcons,vars)
89 -}
90
91
92 collect_tdefs :: TyCon -> [C.Tdef] -> [C.Tdef]
93 collect_tdefs tcon tdefs 
94   | isAlgTyCon tcon = tdef : tdefs
95   where
96     tdef | isNewTyCon tcon
97          = C.Newtype (make_con_id (tyConName tcon)) (map make_tbind tyvars) (make_ty rep)
98          | otherwise
99          = C.Data (make_con_id (tyConName tcon)) (map make_tbind tyvars) (map make_cdef (tyConDataCons tcon)) 
100     (_, rep) = newTyConRep tcon
101     tyvars   = tyConTyVars tcon
102
103 collect_tdefs _ tdefs = tdefs
104
105
106 make_cdef :: DataCon -> C.Cdef
107 make_cdef dcon =  C.Constr dcon_name existentials tys
108   where 
109     dcon_name = make_con_id (idName (dataConId dcon))
110     existentials = map make_tbind ex_tyvars
111           where (_,_,ex_tyvars,_,_,_) = dataConSig dcon
112     tys = map make_ty (dataConRepArgTys dcon)
113
114 make_tbind :: TyVar -> C.Tbind
115 make_tbind tv = (make_var_id (tyVarName tv), make_kind (tyVarKind tv))
116     
117 make_vbind :: Var -> C.Vbind
118 make_vbind v = (make_var_id  (Var.varName v), make_ty (varType v))
119
120 make_vdef :: CoreBind -> (Bool, C.Vdefg)
121 make_vdef b = 
122   case b of
123     NonRec v e -> (isGlobalId v,C.Nonrec (f (v,e)))
124     Rec ves -> (or (map g ves),C.Rec (map f ves))
125   where f (v,e) = (n,t,make_exp e)
126                   where (n,t) = make_vbind v
127         g (v,e) = isGlobalId v
128
129 make_exp :: CoreExpr -> C.Exp
130 make_exp (Var v) =  
131   case globalIdDetails v of
132     DataConId _ -> C.Dcon (make_con_qid (Var.varName v))
133     FCallId (CCall (CCallSpec (StaticTarget nm) _ _)) -> C.Ccall (_UNPK_ nm) (make_ty (varType v))
134     _ -> C.Var (make_var_qid (Var.varName v))
135 make_exp (Lit l) = C.Lit (make_lit l)
136 make_exp (App e (Type t)) = C.Appt (make_exp e) (make_ty t)
137 make_exp (App e1 e2) = C.App (make_exp e1) (make_exp e2)
138 make_exp (Lam v e) | isTyVar v = C.Lam (C.Tb (make_tbind v)) (make_exp e)
139 make_exp (Lam v e) | otherwise = C.Lam (C.Vb (make_vbind v)) (make_exp e)
140 make_exp (Let b e) = C.Let (snd (make_vdef b)) (make_exp e)
141 make_exp (Case e v alts) = C.Case (make_exp e) (make_vbind v) (map make_alt alts)
142 make_exp (Note (SCC cc) e) = C.Note "SCC"  (make_exp e) -- temporary
143 make_exp (Note (Coerce t_to t_from) e) = C.Coerce (make_ty t_to) (make_exp e)
144 make_exp (Note InlineCall e) = C.Note "InlineCall" (make_exp e)
145 make_exp (Note InlineMe e) = C.Note "InlineMe" (make_exp e)
146 make_exp _ = error "MkExternalCore died: make_exp"
147
148 make_alt :: CoreAlt -> C.Alt
149 make_alt (DataAlt dcon, vs, e) = 
150     C.Acon (make_con_qid (idName (dataConId dcon))) (map make_tbind tbs) (map make_vbind vbs) (make_exp e)
151         where (tbs,vbs) = span isTyVar vs
152 make_alt (LitAlt l,_,e) = C.Alit (make_lit l) (make_exp e)
153 make_alt (DEFAULT,[],e) = C.Adefault (make_exp e)
154
155 make_lit :: Literal -> C.Lit
156 make_lit l = 
157   case l of
158     MachChar i -> C.Lchar (chr i) t
159     MachStr s -> C.Lstring (_UNPK_ s) t
160     MachAddr i -> C.Lint i t  
161     MachInt i -> C.Lint i t
162     MachInt64 i -> C.Lint i t
163     MachWord i -> C.Lint i t
164     MachWord64 i -> C.Lint i t
165     MachFloat r -> C.Lrational r t
166     MachDouble r -> C.Lrational r t
167     MachLabel s -> C.Lstring (_UNPK_ s) t
168     _ -> error "MkExternalCore died: make_lit"
169   where 
170     t = make_ty (literalType l)
171
172 make_ty :: Type -> C.Ty
173 make_ty (TyVarTy tv) = C.Tvar (make_var_id (tyVarName tv))
174 make_ty (AppTy t1 t2) = C.Tapp (make_ty t1) (make_ty t2)
175 make_ty (TyConApp tc ts) = foldl C.Tapp (C.Tcon (make_con_qid (tyConName tc))) (map make_ty ts)
176 make_ty (FunTy t1 t2) = make_ty (TyConApp funTyCon [t1,t2])
177 make_ty (ForAllTy tv t) = C.Tforall (make_tbind tv) (make_ty t)
178 make_ty (SourceTy p) = make_ty (sourceTypeRep p)
179 make_ty (UsageTy _ t) = make_ty t
180 make_ty (NoteTy _ t) = make_ty t
181
182
183 make_kind :: Kind -> C.Kind
184 make_kind (FunTy k1 k2) = C.Karrow (make_kind k1) (make_kind k2)
185 make_kind k | k `eqKind` liftedTypeKind = C.Klifted
186 make_kind k | k `eqKind` unliftedTypeKind = C.Kunlifted
187 make_kind k | k `eqKind` openTypeKind = C.Kopen
188 make_kind _ = error "MkExternalCore died: make_kind"
189
190 {- Id generation. -}
191
192 {- Use encoded strings, except restore non-leading '#'s.
193    Also, adjust casing to work around some badly-chosen internal names. -}
194 make_id :: Bool -> Name -> C.Id
195 make_id is_var nm = 
196   case n of
197     c:cs -> if isUpper c && is_var then (toLower c):(decode cs) else (decode n)
198   where n = (occNameString . nameOccName) nm
199         decode ('z':'h':cs) = '#':(decode cs)
200         decode (c:cs) = c:(decode cs)
201         decode [] = []
202
203 make_var_id :: Name -> C.Id
204 make_var_id = make_id True
205
206 make_con_id :: Name -> C.Id
207 make_con_id = make_id False
208
209 make_mid :: Module -> C.Id
210 make_mid = moduleNameString . moduleName
211
212 make_qid :: Bool -> Name -> C.Qual C.Id
213 make_qid is_var n = (mname,make_id is_var n)
214     where mname = 
215            case nameModule_maybe n of
216             Just m -> make_mid m
217             Nothing -> ""   -- for now!
218
219 make_var_qid :: Name -> C.Qual C.Id
220 make_var_qid = make_qid True
221
222 make_con_qid :: Name -> C.Qual C.Id
223 make_con_qid = make_qid False
224
225 \end{code}
226
227
228
229