MkExternalCore.lhs 8.53 KB
Newer Older
apt's avatar
apt committed
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
%
% (c) The University of Glasgow 2001
%
\begin{code}

module MkExternalCore (
	emitExternalCore
) where

#include "HsVersions.h"

import qualified ExternalCore as C
import Char
import Module
import CoreSyn
import HscTypes	
import TyCon
18
import Class
apt's avatar
apt committed
19
20
21
22
23
24
import TypeRep
import Type
import DataCon
import CoreSyn
import Var
import IdInfo
25
import Id( idUnfolding )
26
27
import CoreTidy( tidyExpr )
import VarEnv( emptyTidyEnv )
apt's avatar
apt committed
28
29
30
31
32
33
34
import Literal
import Name
import CostCentre
import Outputable
import ForeignCall
import PprExternalCore	
import CmdLineOpts
35
import Maybes( orElse )
apt's avatar
apt committed
36
import IO
37
import FastString
apt's avatar
apt committed
38

39
40
emitExternalCore :: DynFlags -> ModGuts -> IO ()
emitExternalCore dflags mod_impl
apt's avatar
apt committed
41
42
 | opt_EmitExternalCore 
 = (do handle <- openFile corename WriteMode
43
       hPutStrLn handle (show (mkExternalCore mod_impl))      
apt's avatar
apt committed
44
45
46
47
       hClose handle)
   `catch` (\err -> pprPanic "Failed to open or write external core output file" 
	                     (text corename))
   where corename = extCoreName dflags
48
emitExternalCore _ _
apt's avatar
apt committed
49
50
51
52
 | otherwise
 = return ()


53
mkExternalCore :: ModGuts -> C.Module
54
55
56
57
-- The ModGuts has been tidied, but the implicit bindings have
-- not been injected, so we have to add them manually here
-- We don't include the strange data-con *workers* because they are
-- implicit in the data type declaration itself
58
mkExternalCore (ModGuts {mg_module=this_mod, mg_types = type_env, mg_binds = binds})
59
  = C.Module mname tdefs (map make_vdef all_binds)
apt's avatar
apt committed
60
  where
61
62
    mname  = make_mid this_mod
    tdefs  = foldr collect_tdefs [] tycons
63
64
65
66
67
68

    all_binds  = implicit_con_wrappers ++ other_implicit_binds ++ binds
		-- Put the constructor wrappers first, because
		-- other implicit bindings (notably the fromT functions arising 
		-- from generics) use the constructor wrappers.

69
70
    tycons = map classTyCon (typeEnvClasses type_env) ++ typeEnvTyCons type_env

71
72
73
74
75
76
    implicit_con_wrappers = map get_defn (concatMap implicit_con_ids   (typeEnvElts type_env))
    other_implicit_binds  = map get_defn (concatMap other_implicit_ids (typeEnvElts type_env))

implicit_con_ids :: TyThing -> [Id]
implicit_con_ids (ATyCon tc) = map dataConWrapId (tyConDataCons_maybe tc `orElse` [])
implicit_con_ids other       = []
77

78
79
80
81
other_implicit_ids :: TyThing -> [Id]
other_implicit_ids (ATyCon tc) = tyConSelIds tc ++ tyConGenIds tc
other_implicit_ids (AClass cl) = classSelIds cl
other_implicit_ids other       = []
82
83

get_defn :: Id -> CoreBind
84
85
86
87
88
89
90
get_defn id = NonRec id rhs
	    where
	      rhs  = tidyExpr emptyTidyEnv body 
	      body = unfoldingTemplate (idUnfolding id)
	-- Don't forget to tidy the body !  Otherwise you get silly things like
	--	\ tpl -> case tpl of tpl -> (tpl,tpl) -> tpl
	-- Maybe we should inject these bindings during CoreTidy?
apt's avatar
apt committed
91
92

collect_tdefs :: TyCon -> [C.Tdef] -> [C.Tdef]
93
collect_tdefs tcon tdefs 
apt's avatar
apt committed
94
  | isAlgTyCon tcon = tdef: tdefs
95
  where
apt's avatar
apt committed
96
    tdef | isNewTyCon tcon = 
apt's avatar
apt committed
97
                C.Newtype (make_con_qid (tyConName tcon)) (map make_tbind tyvars) repclause 
apt's avatar
apt committed
98
         | otherwise = 
apt's avatar
apt committed
99
                C.Data (make_con_qid (tyConName tcon)) (map make_tbind tyvars) (map make_cdef (tyConDataCons tcon)) 
apt's avatar
apt committed
100
101
102
103
         where repclause | isRecursiveTyCon tcon = Nothing
		         | otherwise = Just (make_ty rep)
                                           where (_, rep) = newTyConRep tcon
    tyvars = tyConTyVars tcon
104

apt's avatar
apt committed
105
106
107
108
109
110
collect_tdefs _ tdefs = tdefs


make_cdef :: DataCon -> C.Cdef
make_cdef dcon =  C.Constr dcon_name existentials tys
  where 
111
    dcon_name    = make_con_qid (dataConName dcon)
apt's avatar
apt committed
112
    existentials = map make_tbind ex_tyvars
113
114
    ex_tyvars    = dataConExistentialTyVars dcon
    tys 	 = map make_ty (dataConRepArgTys dcon)
apt's avatar
apt committed
115
116
117
118
119
120
121

make_tbind :: TyVar -> C.Tbind
make_tbind tv = (make_var_id (tyVarName tv), make_kind (tyVarKind tv))
    
make_vbind :: Var -> C.Vbind
make_vbind v = (make_var_id  (Var.varName v), make_ty (varType v))

apt's avatar
apt committed
122
make_vdef :: CoreBind -> C.Vdefg
apt's avatar
apt committed
123
124
make_vdef b = 
  case b of
apt's avatar
apt committed
125
126
127
    NonRec v e -> C.Nonrec (f (v,e))
    Rec ves -> C.Rec (map f ves)
  where f (v,e) = (make_var_qid (Var.varName v), make_ty (varType v),make_exp e)
apt's avatar
apt committed
128
129
130
131

make_exp :: CoreExpr -> C.Exp
make_exp (Var v) =  
  case globalIdDetails v of
132
133
     -- a DataConId represents the Id of a worker, which is a varName. -- sof 4/02
--    DataConId _ -> C.Dcon (make_con_qid (Var.varName v))
134
    FCallId (CCall (CCallSpec (StaticTarget nm) _ _)) -> C.External (unpackFS nm) (make_ty (varType v))
apt's avatar
apt committed
135
    FCallId _ -> error "MkExternalCore died: can't handle non-static-C foreign call"
apt's avatar
apt committed
136
    _ -> C.Var (make_var_qid (Var.varName v))
137
make_exp (Lit (l@(MachLabel s))) = C.External (unpackFS s) (make_ty (literalType l))
apt's avatar
apt committed
138
139
140
141
142
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)
make_exp (Lam v e) | isTyVar v = C.Lam (C.Tb (make_tbind v)) (make_exp e)
make_exp (Lam v e) | otherwise = C.Lam (C.Vb (make_vbind v)) (make_exp e)
apt's avatar
apt committed
143
make_exp (Let b e) = C.Let (make_vdef b) (make_exp e)
apt's avatar
apt committed
144
145
146
147
148
149
150
151
152
make_exp (Case e v alts) = C.Case (make_exp e) (make_vbind v) (map make_alt alts)
make_exp (Note (SCC cc) e) = C.Note "SCC"  (make_exp e) -- temporary
make_exp (Note (Coerce t_to t_from) e) = C.Coerce (make_ty t_to) (make_exp e)
make_exp (Note InlineCall e) = C.Note "InlineCall" (make_exp e)
make_exp (Note InlineMe e) = C.Note "InlineMe" (make_exp e)
make_exp _ = error "MkExternalCore died: make_exp"

make_alt :: CoreAlt -> C.Alt
make_alt (DataAlt dcon, vs, e) = 
153
154
155
156
    C.Acon (make_con_qid (dataConName dcon))
           (map make_tbind tbs)
           (map make_vbind vbs)
	   (make_exp e)    
apt's avatar
apt committed
157
158
159
160
161
162
163
	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)

make_lit :: Literal -> C.Lit
make_lit l = 
  case l of
apt's avatar
apt committed
164
165
    MachChar i | i <= 0xff -> C.Lchar (chr i) t
    MachChar i | otherwise -> C.Lint (toEnum i) t
166
    MachStr s -> C.Lstring (unpackFS s) t
apt's avatar
apt committed
167
168
169
170
171
172
173
174
175
176
177
178
    MachAddr i -> C.Lint i t  
    MachInt i -> C.Lint i t
    MachInt64 i -> C.Lint i t
    MachWord i -> C.Lint i t
    MachWord64 i -> C.Lint i t
    MachFloat r -> C.Lrational r t
    MachDouble r -> C.Lrational r t
    _ -> error "MkExternalCore died: make_lit"
  where 
    t = make_ty (literalType l)

make_ty :: Type -> C.Ty
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
make_ty (TyVarTy tv)    	 = C.Tvar (make_var_id (tyVarName tv))
make_ty (AppTy t1 t2) 		 = C.Tapp (make_ty t1) (make_ty t2)
make_ty (FunTy t1 t2) 		 = make_ty (TyConApp funTyCon [t1,t2])
make_ty (ForAllTy tv t) 	 = C.Tforall (make_tbind tv) (make_ty t)
make_ty (TyConApp tc ts) 	 = foldl C.Tapp (C.Tcon (make_con_qid (tyConName tc))) 
					 (map make_ty ts)
-- The special case for newtypes says "do not expand newtypes".
-- Reason: sourceTypeRep does substitution and, while substitution deals
-- 	   correctly with name capture, it's only correct if you see the uniques!
--	   If you just see occurrence names, name capture may occur.
-- Example: newtype A a = A (forall b. b -> a)
--	    test :: forall q b. q -> A b
--	    test _ = undefined
-- 	Here the 'a' gets substituted by 'b', which is captured.
-- Another solution would be to expand newtypes before tidying; but that would
-- expose the representation in interface files, which definitely isn't right.
-- Maybe CoreTidy should know whether to expand newtypes or not?

make_ty (SourceTy (NType tc ts)) = foldl C.Tapp (C.Tcon (make_con_qid (tyConName tc))) 
					 (map make_ty ts)

make_ty (SourceTy p)		 = make_ty (sourceTypeRep p)
make_ty (NoteTy _ t) 		 = make_ty t

apt's avatar
apt committed
203
204
205
206


make_kind :: Kind -> C.Kind
make_kind (FunTy k1 k2) = C.Karrow (make_kind k1) (make_kind k2)
207
208
209
make_kind k | k `eqKind` liftedTypeKind = C.Klifted
make_kind k | k `eqKind` unliftedTypeKind = C.Kunlifted
make_kind k | k `eqKind` openTypeKind = C.Kopen
apt's avatar
apt committed
210
211
212
213
make_kind _ = error "MkExternalCore died: make_kind"

{- Id generation. -}

apt's avatar
apt committed
214
{- Use encoded strings.
apt's avatar
apt committed
215
216
   Also, adjust casing to work around some badly-chosen internal names. -}
make_id :: Bool -> Name -> C.Id
217
218
219
make_id is_var nm = (occNameString . nameOccName) nm

{-	SIMON thinks this stuff isn't necessary
apt's avatar
apt committed
220
221
make_id is_var nm = 
  case n of
apt's avatar
apt committed
222
223
224
225
226
    'Z':cs | is_var -> 'z':cs 
    'z':cs | not is_var -> 'Z':cs 
    c:cs | isUpper c && is_var -> 'z':'d':n
    c:cs | isLower c && (not is_var) -> 'Z':'d':n
    _ -> n
apt's avatar
apt committed
227
  where n = (occNameString . nameOccName) nm
228
-}
apt's avatar
apt committed
229
230
231
232
233
234
235
236
237
238
239
240

make_var_id :: Name -> C.Id
make_var_id = make_id True

make_mid :: Module -> C.Id
make_mid = moduleNameString . moduleName

make_qid :: Bool -> Name -> C.Qual C.Id
make_qid is_var n = (mname,make_id is_var n)
    where mname = 
           case nameModule_maybe n of
            Just m -> make_mid m
apt's avatar
apt committed
241
            Nothing -> "" 
apt's avatar
apt committed
242
243
244
245
246
247
248
249
250
251
252
253

make_var_qid :: Name -> C.Qual C.Id
make_var_qid = make_qid True

make_con_qid :: Name -> C.Qual C.Id
make_con_qid = make_qid False

\end{code}