Reorganisation of the source tree

Most of the other users of the fptools build system have migrated to
Cabal, and with the move to darcs we can now flatten the source tree
without losing history, so here goes.

The main change is that the ghc/ subdir is gone, and most of what it
contained is now at the top level.  The build system now makes no
pretense at being multi-project, it is just the GHC build system.

No doubt this will break many things, and there will be a period of
instability while we fix the dependencies.  A straightforward build
should work, but I haven't yet fixed binary/source distributions.
Changes to the Building Guide will follow, too.

1 files changed, 151 insertions, 0 deletions

diff --git a/utils/ext-core/Prep.hs b/utils/ext-core/Prep.hs
new file mode 100644
index 0000000000..ee65eaaba2
--- /dev/null
+++ b/utils/ext-core/Prep.hs
@@ -0,0 +1,151 @@
+{- 
+Preprocess a module to normalize it in the following ways:
+	(1) Saturate all constructor and primop applications. 
+	(2) Arrange that any non-trivial expression of unlifted kind ('#')
+             is turned into the scrutinee of a Case.
+After these preprocessing steps, Core can be interpreted (or given an operational semantics)
+      ignoring type information almost completely.
+-}
+
+
+module Prep where
+
+import Prims
+import Core
+import Printer
+import Env
+import Check
+
+primArgTys :: Env Var [Ty]
+primArgTys = efromlist (map f Prims.primVals)
+  where f (v,t) = (v,atys)
+             where (_,atys,_) = splitTy t
+
+prepModule :: Menv -> Module -> Module
+prepModule globalEnv (Module mn tdefs vdefgs) = 
+    Module mn tdefs vdefgs' 
+  where
+    (_,vdefgs') = foldl prepTopVdefg (eempty,[]) vdefgs
+
+    prepTopVdefg (venv,vdefgs) vdefg = (venv',vdefgs ++ [vdefg'])
+       where (venv',vdefg') = prepVdefg (venv,eempty) vdefg
+ 
+    prepVdefg (env@(venv,_)) (Nonrec(Vdef(("",x),t,e))) = 
+	(eextend venv (x,t), Nonrec(Vdef(("",x),t,prepExp env e)))
+    prepVdefg (env@(venv,_))  (Nonrec(Vdef(qx,t,e))) = 
+	(venv, Nonrec(Vdef(qx,t,prepExp env e)))
+    prepVdefg (venv,tvenv) (Rec vdefs) = 
+	(venv',Rec [Vdef(qx,t,prepExp (venv',tvenv) e) | Vdef(qx,t,e) <- vdefs])
+	where venv' = foldl eextend venv [(x,t) | Vdef(("",x),t,_) <- vdefs]
+
+    prepExp env (Var qv) = Var qv
+    prepExp env (Dcon qdc) = Dcon qdc
+    prepExp env (Lit l) = Lit l
+    prepExp env e@(App _ _) = unwindApp env e []
+    prepExp env e@(Appt _ _) = unwindApp env e []
+    prepExp (venv,tvenv) (Lam (Vb vb) e) = Lam (Vb vb) (prepExp (eextend venv vb,tvenv) e)
+    prepExp (venv,tvenv) (Lam (Tb tb) e) = Lam (Tb tb) (prepExp (venv,eextend tvenv tb) e)
+    prepExp env@(venv,tvenv) (Let (Nonrec(Vdef(("",x),t,b))) e) | kindof tvenv t == Kunlifted && suspends b =
+		Case (prepExp env b) (x,t) [Adefault (prepExp (eextend venv (x,t),tvenv) e)]
+    prepExp (venv,tvenv) (Let vdefg e) =  Let vdefg' (prepExp (venv',tvenv) e)
+		where (venv',vdefg') = prepVdefg (venv,tvenv) vdefg
+    prepExp env@(venv,tvenv) (Case e vb alts) = Case (prepExp env e) vb (map (prepAlt (eextend venv vb,tvenv)) alts)
+    prepExp env (Coerce t e) = Coerce t (prepExp env e)
+    prepExp env (Note s e) = Note s (prepExp env e)
+    prepExp env (External s t) = External s t
+
+    prepAlt (venv,tvenv) (Acon qdc tbs vbs e) = Acon qdc tbs vbs (prepExp (foldl eextend venv vbs,foldl eextend tvenv tbs) e)
+    prepAlt env (Alit l e) = Alit l (prepExp env e)
+    prepAlt env (Adefault e) = Adefault (prepExp env e)
+
+
+    unwindApp env (App e1 e2) as = unwindApp env e1 (Left e2:as)
+    unwindApp env (Appt e t) as  = unwindApp env e (Right t:as)
+    unwindApp env (op@(Dcon qdc)) as =
+        etaExpand (drop n atys) (rewindApp env op as)
+        where (tbs,atys0,_) = splitTy (qlookup cenv_ eempty qdc)
+	      atys = map (substl (map fst tbs) ts) atys0
+	      ts = [t | Right t <- as]
+              n = length [e | Left e <- as]
+    unwindApp env (op@(Var(m,p))) as | m == primMname =
+	etaExpand (drop n atys) (rewindApp env op as)
+        where Just atys = elookup primArgTys p
+              n = length [e | Left e <- as]
+    unwindApp env op as = rewindApp env op as
+
+
+    etaExpand ts e = foldl g e [('$':(show i),t) | (i,t) <- zip [1..] ts]
+	  where g e (v,t) = Lam (Vb(v,t)) (App e (Var ("",v)))
+
+    rewindApp env e [] = e
+    rewindApp env@(venv,tvenv) e1 (Left e2:as) | kindof tvenv t == Kunlifted && suspends e2 =
+	Case (prepExp env' e2) (v,t)
+		[Adefault (rewindApp env' (App e1 (Var ("",v))) as)]
+        where v = freshVar venv
+              t = typeofExp env e2
+              env' = (eextend venv (v,t),tvenv)
+    rewindApp env e1 (Left e2:as) = rewindApp env (App e1 (prepExp env e2)) as
+    rewindApp env e (Right t:as) = rewindApp env (Appt e t) as
+
+    freshVar venv = maximum ("":edomain venv) ++ "x" -- one simple way!
+
+    typeofExp :: (Venv,Tvenv) -> Exp -> Ty
+    typeofExp (venv,_) (Var qv) = qlookup venv_ venv qv
+    typeofExp env (Dcon qdc) = qlookup cenv_ eempty qdc
+    typeofExp env (Lit l) = typeofLit l
+	where typeofLit (Lint _ t) = t
+	      typeofLit (Lrational _ t) = t
+	      typeofLit (Lchar _ t) = t
+              typeofLit (Lstring _ t) = t
+    typeofExp env (App e1 e2) = t
+          where (Tapp(Tapp _ t0) t) = typeofExp env e1
+    typeofExp env (Appt e t) = substl [tv] [t] t'
+	  where (Tforall (tv,_) t') = typeofExp env e
+    typeofExp (venv,tvenv) (Lam (Vb(v,t)) e) = tArrow t (typeofExp (eextend venv (v,t),tvenv) e)
+    typeofExp (venv,tvenv) (Lam (Tb tb) e) = Tforall tb (typeofExp (venv,eextend tvenv tb) e)
+    typeofExp (venv,tvenv) (Let vdefg e) = typeofExp (venv',tvenv) e
+	  where venv' = case vdefg of
+			  Nonrec (Vdef((_,x),t,_)) -> eextend venv (x,t)
+                          Rec vdefs -> foldl eextend venv [(x,t) | Vdef((_,x),t,_) <- vdefs]
+    typeofExp (venv,tvenv) (Case _ vb (alt:_)) = typeofAlt (eextend venv vb,tvenv) alt
+	where typeofAlt (venv,tvenv) (Acon _ tbs vbs e) = typeofExp (foldl eextend venv vbs,foldl eextend tvenv tbs) e
+	      typeofAlt env (Alit _ e) = typeofExp env e
+	      typeofAlt env (Adefault e) = typeofExp env e
+    typeofExp env (Coerce t _) = t
+    typeofExp env (Note _ e) = typeofExp env e
+    typeofExp env (External _ t) = t
+
+    {- Return false for those expressions for which Interp.suspendExp buidds a thunk. -}
+    suspends (Var _) = False
+    suspends (Lit _) = False
+    suspends (Lam (Vb _) _) = False
+    suspends (Lam _ e) = suspends e
+    suspends (Appt e _) = suspends e
+    suspends (Coerce _ e) = suspends e
+    suspends (Note _ e) = suspends e
+    suspends (External _ _) = False
+    suspends _ = True
+
+    kindof :: Tvenv -> Ty -> Kind
+    kindof tvenv (Tvar tv) = 
+      case elookup tvenv tv of
+	Just k -> k
+        Nothing -> error ("impossible Tyvar " ++ show tv)
+    kindof tvenv (Tcon qtc) = qlookup tcenv_ eempty qtc
+    kindof tvenv (Tapp t1 t2) = k2
+	where Karrow _ k2 = kindof tvenv t1
+    kindof tvenv (Tforall _ t) = kindof tvenv t
+
+    mlookup :: (Envs -> Env a b) -> Env a b -> Mname -> Env a b
+    mlookup _ local_env "" = local_env
+    mlookup selector _  m =   
+      case elookup globalEnv m of
+        Just env -> selector env
+        Nothing -> error ("undefined module name: " ++ m)
+
+    qlookup ::  (Ord a, Show a) => (Envs -> Env a b) -> Env a b -> (Mname,a) -> b
+    qlookup selector local_env (m,k) =   
+      case elookup (mlookup selector local_env m) k of
+        Just v -> v
+        Nothing -> error ("undefined identifier: " ++ show k)
+