MkExternalCore.lhs 7.8 KB
Newer Older
1

Simon Marlow's avatar
Simon Marlow committed
2
% (c) The University of Glasgow 2001-2006
apt's avatar
apt committed
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
%
\begin{code}

module MkExternalCore (
	emitExternalCore
) where

#include "HsVersions.h"

import qualified ExternalCore as C
import Char
import Module
import CoreSyn
import HscTypes	
import TyCon
import TypeRep
import Type
20
import PprExternalCore	-- Instances
Simon Marlow's avatar
Simon Marlow committed
21
import DataCon
apt's avatar
apt committed
22
23
24
25
26
import CoreSyn
import Var
import IdInfo
import Literal
import Name
Simon Marlow's avatar
Simon Marlow committed
27
28
import NameSet
import UniqSet
apt's avatar
apt committed
29
30
import Outputable
import ForeignCall
Simon Marlow's avatar
Simon Marlow committed
31
32
import DynFlags
import StaticFlags
apt's avatar
apt committed
33
import IO
34
import FastString
apt's avatar
apt committed
35

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


50
mkExternalCore :: NameSet -> CgGuts -> C.Module
51
52
53
54
-- 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
55
56
mkExternalCore exports (CgGuts {cg_module=this_mod, cg_tycons = tycons, cg_binds = binds})
  = C.Module mname tdefs (map (make_vdef exports) binds)
apt's avatar
apt committed
57
  where
58
59
    mname  = make_mid this_mod
    tdefs  = foldr collect_tdefs [] tycons
60

apt's avatar
apt committed
61
collect_tdefs :: TyCon -> [C.Tdef] -> [C.Tdef]
62
collect_tdefs tcon tdefs 
apt's avatar
apt committed
63
  | isAlgTyCon tcon = tdef: tdefs
64
  where
apt's avatar
apt committed
65
    tdef | isNewTyCon tcon = 
apt's avatar
apt committed
66
                C.Newtype (make_con_qid (tyConName tcon)) (map make_tbind tyvars) repclause 
67
68
-- 20060420 GHC handles empty data types just fine. ExtCore should too! jds
--         | null (tyConDataCons tcon) = error "MkExternalCore died: can't handle datatype declarations with no data constructors"
apt's avatar
apt committed
69
         | otherwise = 
apt's avatar
apt committed
70
                C.Data (make_con_qid (tyConName tcon)) (map make_tbind tyvars) (map make_cdef (tyConDataCons tcon)) 
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
71
         where repclause | isRecursiveTyCon tcon || isOpenTyCon tcon= Nothing
apt's avatar
apt committed
72
73
74
		         | otherwise = Just (make_ty rep)
                                           where (_, rep) = newTyConRep tcon
    tyvars = tyConTyVars tcon
75

apt's avatar
apt committed
76
77
78
79
80
81
collect_tdefs _ tdefs = tdefs


make_cdef :: DataCon -> C.Cdef
make_cdef dcon =  C.Constr dcon_name existentials tys
  where 
82
    dcon_name    = make_var_id (dataConName dcon)
apt's avatar
apt committed
83
    existentials = map make_tbind ex_tyvars
84
    ex_tyvars    = dataConExTyVars dcon
85
    tys 	 = map make_ty (dataConRepArgTys dcon)
apt's avatar
apt committed
86
87
88
89
90

make_tbind :: TyVar -> C.Tbind
make_tbind tv = (make_var_id (tyVarName tv), make_kind (tyVarKind tv))
    
make_vbind :: Var -> C.Vbind
91
make_vbind v = (make_var_id  (Var.varName v), make_ty (idType v))
apt's avatar
apt committed
92

93
94
make_vdef :: NameSet -> CoreBind -> C.Vdefg
make_vdef exports b = 
apt's avatar
apt committed
95
  case b of
apt's avatar
apt committed
96
97
    NonRec v e -> C.Nonrec (f (v,e))
    Rec ves -> C.Rec (map f ves)
98
99
100
  where
  f (v,e) = (local, make_var_id (Var.varName v), make_ty (idType v),make_exp e)
  	where local = not $ elementOfUniqSet (Var.varName v) exports
101
	-- Top level bindings are unqualified now
apt's avatar
apt committed
102
103
104
105

make_exp :: CoreExpr -> C.Exp
make_exp (Var v) =  
  case globalIdDetails v of
106
107
     -- a DataConId represents the Id of a worker, which is a varName. -- sof 4/02
--    DataConId _ -> C.Dcon (make_con_qid (Var.varName v))
108
109
110
111
112
113
114
    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)
apt's avatar
apt committed
115
    _ -> C.Var (make_var_qid (Var.varName v))
116
make_exp (Lit (l@(MachLabel s _))) = C.Label (unpackFS s)
apt's avatar
apt committed
117
118
119
120
121
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)
122
123
make_exp (Cast e co) = C.Cast (make_exp e) (make_ty co)
make_exp (Let b e) = C.Let (make_vdef emptyNameSet b) (make_exp e)
124
125
-- gaw 2004
make_exp (Case e v ty alts) = C.Case (make_exp e) (make_vbind v) (make_ty ty) (map make_alt alts)
apt's avatar
apt committed
126
make_exp (Note (SCC cc) e) = C.Note "SCC"  (make_exp e) -- temporary
127
make_exp (Note (CoreNote s) e) = C.Note s (make_exp e)  -- hdaume: core annotations
apt's avatar
apt committed
128
129
130
131
132
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) = 
133
134
135
136
    C.Acon (make_con_qid (dataConName dcon))
           (map make_tbind tbs)
           (map make_vbind vbs)
	   (make_exp e)    
apt's avatar
apt committed
137
138
139
140
141
142
143
	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
144
    MachChar i -> C.Lchar i t
145
    MachStr s -> C.Lstring (unpackFS s) t
sof's avatar
sof committed
146
    MachNullAddr -> C.Lint 0 t
apt's avatar
apt committed
147
148
149
150
151
152
153
154
155
156
157
    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
158
159
160
161
162
163
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)
164
-- Newtypes are treated just like any other type constructor; not expanded
165
-- Reason: predTypeRep does substitution and, while substitution deals
166
167
168
169
170
171
172
173
174
175
-- 	   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?

176
177
make_ty (PredTy p)	= make_ty (predTypeRep p)
make_ty (NoteTy _ t) 	= make_ty t
178

apt's avatar
apt committed
179
180
181


make_kind :: Kind -> C.Kind
182
make_kind (PredTy p) | isEqPred p = panic "coercion kinds in external core not implemented!"
183
184
185
186
187
make_kind (FunTy k1 k2)  = C.Karrow (make_kind k1) (make_kind k2)
make_kind k
  | isLiftedTypeKind k   = C.Klifted
  | isUnliftedTypeKind k = C.Kunlifted
  | isOpenTypeKind k     = C.Kopen
apt's avatar
apt committed
188
189
190
191
make_kind _ = error "MkExternalCore died: make_kind"

{- Id generation. -}

apt's avatar
apt committed
192
{- Use encoded strings.
apt's avatar
apt committed
193
194
   Also, adjust casing to work around some badly-chosen internal names. -}
make_id :: Bool -> Name -> C.Id
195
196
197
make_id is_var nm = (occNameString . nameOccName) nm

{-	SIMON thinks this stuff isn't necessary
apt's avatar
apt committed
198
199
make_id is_var nm = 
  case n of
apt's avatar
apt committed
200
201
202
203
204
    '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
205
  where n = (occNameString . nameOccName) nm
206
-}
apt's avatar
apt committed
207
208
209
210
211

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

make_mid :: Module -> C.Id
Simon Marlow's avatar
Simon Marlow committed
212
make_mid = showSDoc . pprModule
apt's avatar
apt committed
213
214
215
216
217
218

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
219
            Nothing -> "" 
apt's avatar
apt committed
220
221
222
223
224
225
226
227
228
229
230
231

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}