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}