Implement "value" imports with the CAPI
[ghc.git] / compiler / coreSyn / MkExternalCore.lhs
1
2 % (c) The University of Glasgow 2001-2006
3 %
4 \begin{code}
5 {-# OPTIONS -fno-warn-tabs #-}
6 -- The above warning supression flag is a temporary kludge.
7 -- While working on this module you are encouraged to remove it and
8 -- detab the module (please do the detabbing in a separate patch). See
9 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
10 -- for details
11
12 module MkExternalCore (
13         emitExternalCore
14 ) where
15
16 #include "HsVersions.h"
17
18 import qualified ExternalCore as C
19 import Module
20 import CoreSyn
21 import HscTypes 
22 import TyCon
23 -- import Class
24 import TypeRep
25 import Type
26 import Kind
27 import PprExternalCore () -- Instances
28 import DataCon
29 import Coercion
30 import Var
31 import IdInfo
32 import Literal
33 import Name
34 import Outputable
35 import Encoding
36 import ForeignCall
37 import DynFlags
38 import FastString
39 import Exception
40
41 import Data.Char
42 import System.IO
43
44 emitExternalCore :: DynFlags -> CgGuts -> IO ()
45 emitExternalCore dflags cg_guts
46  | dopt Opt_EmitExternalCore dflags
47  = (do handle <- openFile corename WriteMode
48        hPutStrLn handle (show (mkExternalCore cg_guts))
49        hClose handle)
50    `catchIO` (\_ -> pprPanic "Failed to open or write external core output file"
51                              (text corename))
52    where corename = extCoreName dflags
53 emitExternalCore _ _
54  | otherwise
55  = return ()
56
57 -- Reinventing the Reader monad; whee.
58 newtype CoreM a = CoreM (CoreState -> (CoreState, a))
59 type CoreState = Module
60 instance Monad CoreM where
61   (CoreM m) >>= f = CoreM (\ s -> case m s of
62                                     (s',r) -> case f r of
63                                                 CoreM f' -> f' s')
64   return x = CoreM (\ s -> (s, x))
65 runCoreM :: CoreM a -> CoreState -> a
66 runCoreM (CoreM f) s = snd $ f s
67 ask :: CoreM CoreState
68 ask = CoreM (\ s -> (s,s))
69
70 mkExternalCore :: CgGuts -> C.Module
71 -- The ModGuts has been tidied, but the implicit bindings have
72 -- not been injected, so we have to add them manually here
73 -- We don't include the strange data-con *workers* because they are
74 -- implicit in the data type declaration itself
75 mkExternalCore (CgGuts {cg_module=this_mod, cg_tycons = tycons, 
76                         cg_binds = binds})
77 {- Note that modules can be mutually recursive, but even so, we
78    print out dependency information within each module. -}
79   = C.Module mname tdefs (runCoreM (mapM (make_vdef True) binds) this_mod)
80   where
81     mname  = make_mid this_mod
82     tdefs  = foldr collect_tdefs [] tycons
83
84 collect_tdefs :: TyCon -> [C.Tdef] -> [C.Tdef]
85 collect_tdefs tcon tdefs 
86   | isAlgTyCon tcon = tdef: tdefs
87   where
88     tdef | isNewTyCon tcon = 
89                 C.Newtype (qtc tcon) 
90                   (qcc (newTyConCo tcon))
91                   (map make_tbind tyvars) 
92                   (make_ty (snd (newTyConRhs tcon)))
93          | otherwise = 
94                 C.Data (qtc tcon) (map make_tbind tyvars) 
95                    (map make_cdef (tyConDataCons tcon)) 
96     tyvars = tyConTyVars tcon
97
98 collect_tdefs _ tdefs = tdefs
99
100 qtc :: TyCon -> C.Qual C.Tcon
101 qtc = make_con_qid . tyConName
102
103 qcc :: CoAxiom -> C.Qual C.Tcon
104 qcc = make_con_qid . co_ax_name
105
106 make_cdef :: DataCon -> C.Cdef
107 make_cdef dcon =  C.Constr dcon_name existentials tys
108   where 
109     dcon_name    = make_qid False False (dataConName dcon)
110     existentials = map make_tbind ex_tyvars
111     ex_tyvars    = dataConExTyVars 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 :: Bool -> CoreBind -> CoreM C.Vdefg
121 make_vdef topLevel b = 
122   case b of
123     NonRec v e -> f (v,e)     >>= (return . C.Nonrec)
124     Rec ves    -> mapM f ves  >>= (return . C.Rec)
125   where
126   f :: (CoreBndr,CoreExpr) -> CoreM C.Vdef
127   f (v,e) = do
128           localN <- isALocal vName
129           let local = not topLevel || localN
130           rhs <- make_exp e
131           -- use local flag to determine where to add the module name
132           return (local, make_qid local True vName, make_ty (varType v),rhs)
133         where vName = Var.varName v
134
135 make_exp :: CoreExpr -> CoreM C.Exp
136 make_exp (Var v) = do
137   let vName = Var.varName v
138   isLocal <- isALocal vName
139   return $
140      case idDetails v of
141        FCallId (CCall (CCallSpec (StaticTarget nm _ True) callconv _)) 
142            -> C.External (unpackFS nm) (showSDoc (ppr callconv)) (make_ty (varType v))
143        FCallId (CCall (CCallSpec (StaticTarget _ _ False) _ _)) ->
144            panic "make_exp: FFI values not supported"
145        FCallId (CCall (CCallSpec DynamicTarget     callconv _)) 
146            -> C.DynExternal            (showSDoc (ppr callconv)) (make_ty (varType v))
147        -- Constructors are always exported, so make sure to declare them
148        -- with qualified names
149        DataConWorkId _ -> C.Var (make_var_qid False vName)
150        DataConWrapId _ -> C.Var (make_var_qid False vName)
151        _ -> C.Var (make_var_qid isLocal vName)
152 make_exp (Lit (MachLabel s _ _)) = return $ C.Label (unpackFS s)
153 make_exp (Lit l) = return $ C.Lit (make_lit l)
154 make_exp (App e (Type t)) = make_exp e >>= (\ b -> return $ C.Appt b (make_ty t))
155 make_exp (App _e (Coercion _co)) = error "make_exp (App _ (Coercion _))"    -- TODO
156 make_exp (App e1 e2) = do
157    rator <- make_exp e1
158    rand <- make_exp e2
159    return $ C.App rator rand
160 make_exp (Lam v e) | isTyVar v = make_exp e >>= (\ b -> 
161                                     return $ C.Lam (C.Tb (make_tbind v)) b)
162 make_exp (Lam v e) | otherwise = make_exp e >>= (\ b -> 
163                                     return $ C.Lam (C.Vb (make_vbind v)) b)
164 make_exp (Cast e co) = make_exp e >>= (\ b -> return $ C.Cast b (make_co co))
165 make_exp (Let b e) = do
166   vd   <- make_vdef False b
167   body <- make_exp e
168   return $ C.Let vd body
169 make_exp (Case e v ty alts) = do
170   scrut <- make_exp e
171   newAlts  <- mapM make_alt alts
172   return $ C.Case scrut (make_vbind v) (make_ty ty) newAlts
173 make_exp (Tick _ e) = make_exp e >>= (return . C.Tick "SCC") -- temporary
174 make_exp _ = error "MkExternalCore died: make_exp"
175
176 make_alt :: CoreAlt -> CoreM C.Alt
177 make_alt (DataAlt dcon, vs, e) = do
178     newE <- make_exp e
179     return $ C.Acon (make_con_qid (dataConName dcon))
180            (map make_tbind tbs)
181            (map make_vbind vbs)
182            newE
183         where (tbs,vbs) = span isTyVar vs
184 make_alt (LitAlt l,_,e)   = make_exp e >>= (return . (C.Alit (make_lit l)))
185 make_alt (DEFAULT,[],e)   = make_exp e >>= (return . C.Adefault)
186 -- This should never happen, as the DEFAULT alternative binds no variables,
187 -- but we might as well check for it:
188 make_alt a@(DEFAULT,_ ,_) = pprPanic ("MkExternalCore: make_alt: DEFAULT "
189              ++ "alternative had a non-empty var list") (ppr a)
190
191
192 make_lit :: Literal -> C.Lit
193 make_lit l = 
194   case l of
195     -- Note that we need to check whether the character is "big".
196     -- External Core only allows character literals up to '\xff'.
197     MachChar i | i <= chr 0xff -> C.Lchar i t
198     -- For a character bigger than 0xff, we represent it in ext-core
199     -- as an int lit with a char type.
200     MachChar i             -> C.Lint (fromIntegral $ ord i) t 
201     MachStr s -> C.Lstring (unpackFS s) t
202     MachNullAddr -> C.Lint 0 t
203     MachInt i -> C.Lint i t
204     MachInt64 i -> C.Lint i t
205     MachWord i -> C.Lint i t
206     MachWord64 i -> C.Lint i t
207     MachFloat r -> C.Lrational r t
208     MachDouble r -> C.Lrational r t
209     _ -> error "MkExternalCore died: make_lit"
210   where 
211     t = make_ty (literalType l)
212
213 -- Expand type synonyms, then convert.
214 make_ty :: Type -> C.Ty                 -- Be sure to expand types recursively!
215                                         -- example: FilePath ~> String ~> [Char]
216 make_ty t | Just expanded <- tcView t = make_ty expanded
217 make_ty t = make_ty' t
218  
219 -- note calls to make_ty so as to expand types recursively
220 make_ty' :: Type -> C.Ty
221 make_ty' (TyVarTy tv)            = C.Tvar (make_var_id (tyVarName tv))
222 make_ty' (AppTy t1 t2)           = C.Tapp (make_ty t1) (make_ty t2)
223 make_ty' (FunTy t1 t2)           = make_ty (TyConApp funTyCon [t1,t2])
224 make_ty' (ForAllTy tv t)         = C.Tforall (make_tbind tv) (make_ty t)
225 make_ty' (TyConApp tc ts)        = make_tyConApp tc ts
226
227 -- Newtypes are treated just like any other type constructor; not expanded
228 -- Reason: predTypeRep does substitution and, while substitution deals
229 --         correctly with name capture, it's only correct if you see the uniques!
230 --         If you just see occurrence names, name capture may occur.
231 -- Example: newtype A a = A (forall b. b -> a)
232 --          test :: forall q b. q -> A b
233 --          test _ = undefined
234 --      Here the 'a' gets substituted by 'b', which is captured.
235 -- Another solution would be to expand newtypes before tidying; but that would
236 -- expose the representation in interface files, which definitely isn't right.
237 -- Maybe CoreTidy should know whether to expand newtypes or not?
238
239 make_tyConApp :: TyCon -> [Type] -> C.Ty
240 make_tyConApp tc ts =
241   foldl C.Tapp (C.Tcon (qtc tc)) 
242             (map make_ty ts)
243
244 make_kind :: Kind -> C.Kind
245 make_kind (FunTy k1 k2)  = C.Karrow (make_kind k1) (make_kind k2)
246 make_kind k
247   | isLiftedTypeKind k   = C.Klifted
248   | isUnliftedTypeKind k = C.Kunlifted
249   | isOpenTypeKind k     = C.Kopen
250 make_kind _ = error "MkExternalCore died: make_kind"
251
252 {- Id generation. -}
253
254 make_id :: Bool -> Name -> C.Id
255 -- include uniques for internal names in order to avoid name shadowing
256 make_id _is_var nm = ((occNameString . nameOccName) nm)
257   ++ (if isInternalName nm then (show . nameUnique) nm else "")
258
259 make_var_id :: Name -> C.Id
260 make_var_id = make_id True
261
262 -- It's important to encode the module name here, because in External Core,
263 -- base:GHC.Base => base:GHCziBase
264 -- We don't do this in pprExternalCore because we
265 -- *do* want to keep the package name (we don't want baseZCGHCziBase,
266 -- because that would just be ugly.)
267 -- SIGH.
268 -- We encode the package name as well.
269 make_mid :: Module -> C.Id
270 -- Super ugly code, but I can't find anything else that does quite what I
271 -- want (encodes the hierarchical module name without encoding the colon
272 -- that separates the package name from it.)
273 make_mid m = showSDoc $
274               (text $ zEncodeString $ packageIdString $ modulePackageId m)
275               <> text ":"
276               <> (pprEncoded $ pprModuleName $ moduleName m)
277      where pprEncoded = pprCode CStyle
278                
279 make_qid :: Bool -> Bool -> Name -> C.Qual C.Id
280 make_qid force_unqual is_var n = (mname,make_id is_var n)
281     where mname = 
282            case nameModule_maybe n of
283             Just m | not force_unqual -> make_mid m
284             _ -> "" 
285
286 make_var_qid :: Bool -> Name -> C.Qual C.Id
287 make_var_qid force_unqual = make_qid force_unqual True
288
289 make_con_qid :: Name -> C.Qual C.Id
290 make_con_qid = make_qid False False
291
292 make_co :: Coercion -> C.Ty
293 make_co (Refl ty)             = make_ty ty
294 make_co (TyConAppCo tc cos)   = make_conAppCo (qtc tc) cos
295 make_co (AppCo c1 c2)         = C.Tapp (make_co c1) (make_co c2)
296 make_co (ForAllCo tv co)      = C.Tforall (make_tbind tv) (make_co co)
297 make_co (CoVarCo cv)          = C.Tvar (make_var_id (coVarName cv))
298 make_co (AxiomInstCo cc cos)  = make_conAppCo (qcc cc) cos
299 make_co (UnsafeCo t1 t2)      = C.UnsafeCoercion (make_ty t1) (make_ty t2)
300 make_co (SymCo co)            = C.SymCoercion (make_co co)
301 make_co (TransCo c1 c2)       = C.TransCoercion (make_co c1) (make_co c2)
302 make_co (NthCo d co)          = C.NthCoercion d (make_co co)
303 make_co (InstCo co ty)        = C.InstCoercion (make_co co) (make_ty ty)
304
305 -- Used for both tycon app coercions and axiom instantiations.
306 make_conAppCo :: C.Qual C.Tcon -> [Coercion] -> C.Ty
307 make_conAppCo con cos =
308   foldl C.Tapp (C.Tcon con) 
309             (map make_co cos)
310
311 -------
312 isALocal :: Name -> CoreM Bool
313 isALocal vName = do
314   modName <- ask
315   return $ case nameModule_maybe vName of
316              -- Not sure whether isInternalName corresponds to "local"ness
317              -- in the External Core sense; need to re-read the spec.
318              Just m | m == modName -> isInternalName vName
319              _                     -> False
320 \end{code}
321
322
323
324