MkExternalCore.lhs 6.13 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
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
%
% (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
import TypeRep
import Type
import DataCon
import CoreSyn
import Var
import IdInfo
import Literal
import Name
import CostCentre
import Outputable
import ForeignCall
import PprExternalCore	
import CmdLineOpts
import IO

emitExternalCore :: DynFlags -> ModIface -> ModDetails -> IO ()
emitExternalCore dflags iface details 
 | opt_EmitExternalCore 
 = (do handle <- openFile corename WriteMode
       hPutStr handle (show (mkExternalCore iface details))      
       hClose handle)
   `catch` (\err -> pprPanic "Failed to open or write external core output file" 
	                     (text corename))
   where corename = extCoreName dflags
emitExternalCore _ _ _ 
 | otherwise
 = return ()


mkExternalCore :: ModIface -> ModDetails -> C.Module
mkExternalCore (ModIface {mi_module=mi_module,mi_exports=mi_exports}) 
	       (ModDetails {md_types=md_types,md_binds=md_binds}) =
apt's avatar
apt committed
50
    C.Module mname tdefs vdefs
apt's avatar
apt committed
51
52
53
54
55
56
  where
    mname = make_mid mi_module
    tdefs = foldr collect_tdefs [] (typeEnvTyCons md_types)
    vdefs = map make_vdef md_binds

collect_tdefs :: TyCon -> [C.Tdef] -> [C.Tdef]
57
collect_tdefs tcon tdefs 
apt's avatar
apt committed
58
  | isAlgTyCon tcon = tdef: tdefs
59
  where
apt's avatar
apt committed
60
    tdef | isNewTyCon tcon = 
apt's avatar
apt committed
61
                C.Newtype (make_con_qid (tyConName tcon)) (map make_tbind tyvars) repclause 
apt's avatar
apt committed
62
         | otherwise = 
apt's avatar
apt committed
63
                C.Data (make_con_qid (tyConName tcon)) (map make_tbind tyvars) (map make_cdef (tyConDataCons tcon)) 
apt's avatar
apt committed
64
65
66
67
         where repclause | isRecursiveTyCon tcon = Nothing
		         | otherwise = Just (make_ty rep)
                                           where (_, rep) = newTyConRep tcon
    tyvars = tyConTyVars tcon
68

apt's avatar
apt committed
69
70
71
72
73
74
collect_tdefs _ tdefs = tdefs


make_cdef :: DataCon -> C.Cdef
make_cdef dcon =  C.Constr dcon_name existentials tys
  where 
75
    dcon_name    = make_con_qid (idName (dataConWorkId dcon))
apt's avatar
apt committed
76
    existentials = map make_tbind ex_tyvars
77
78
    ex_tyvars    = dataConExistentialTyVars dcon
    tys 	 = map make_ty (dataConRepArgTys dcon)
apt's avatar
apt committed
79
80
81
82
83
84
85

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
86
make_vdef :: CoreBind -> C.Vdefg
apt's avatar
apt committed
87
88
make_vdef b = 
  case b of
apt's avatar
apt committed
89
90
91
    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
92
93
94
95
96

make_exp :: CoreExpr -> C.Exp
make_exp (Var v) =  
  case globalIdDetails v of
    DataConId _ -> C.Dcon (make_con_qid (Var.varName v))
apt's avatar
apt committed
97
98
    FCallId (CCall (CCallSpec (StaticTarget nm) _ _)) -> C.External (_UNPK_ nm) (make_ty (varType v))
    FCallId _ -> error "MkExternalCore died: can't handle non-static-C foreign call"
apt's avatar
apt committed
99
    _ -> C.Var (make_var_qid (Var.varName v))
apt's avatar
apt committed
100
make_exp (Lit (l@(MachLabel s))) = C.External (_UNPK_ s) (make_ty (literalType l))
apt's avatar
apt committed
101
102
103
104
105
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
106
make_exp (Let b e) = C.Let (make_vdef b) (make_exp e)
apt's avatar
apt committed
107
108
109
110
111
112
113
114
115
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) = 
116
    C.Acon (make_con_qid (idName (dataConWorkId dcon))) (map make_tbind tbs) (map make_vbind vbs) (make_exp e)
apt's avatar
apt committed
117
118
119
120
121
122
123
	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
124
125
    MachChar i | i <= 0xff -> C.Lchar (chr i) t
    MachChar i | otherwise -> C.Lint (toEnum i) t
apt's avatar
apt committed
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
    MachStr s -> C.Lstring (_UNPK_ s) t
    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
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 (TyConApp tc ts) = foldl C.Tapp (C.Tcon (make_con_qid (tyConName tc))) (map make_ty ts)
make_ty (FunTy t1 t2) = make_ty (TyConApp funTyCon [t1,t2])
make_ty (ForAllTy tv t) = C.Tforall (make_tbind tv) (make_ty t)
144
make_ty (SourceTy p) = make_ty (sourceTypeRep p)
apt's avatar
apt committed
145
146
147
148
149
make_ty (NoteTy _ t) = make_ty t


make_kind :: Kind -> C.Kind
make_kind (FunTy k1 k2) = C.Karrow (make_kind k1) (make_kind k2)
150
151
152
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
153
154
155
156
make_kind _ = error "MkExternalCore died: make_kind"

{- Id generation. -}

apt's avatar
apt committed
157
{- Use encoded strings.
apt's avatar
apt committed
158
159
160
161
   Also, adjust casing to work around some badly-chosen internal names. -}
make_id :: Bool -> Name -> C.Id
make_id is_var nm = 
  case n of
apt's avatar
apt committed
162
163
164
165
166
    '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
167
168
169
170
171
172
173
174
175
176
177
178
179
  where n = (occNameString . nameOccName) nm

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
180
            Nothing -> "" 
apt's avatar
apt committed
181
182
183
184
185
186
187
188
189
190
191
192

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}