X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=utils%2Fext-core%2FPrep.hs;h=352108e198eaa92b5ec2a0c895b001c5e9fd2209;hp=ee65eaaba2831c6a3d63a6bd478f65e0aba7835d;hb=276585028d51a2516a31b91a91a1f4bba5c9f8ba;hpb=e415eeaf6c7771488af24758ca5b9c22c42be3a6

diff --git a/utils/ext-core/Prep.hs b/utils/ext-core/Prep.hs
index ee65eaa..352108e 100644
--- a/utils/ext-core/Prep.hs
+++ b/utils/ext-core/Prep.hs
@@ -30,13 +30,13 @@ prepModule globalEnv (Module mn tdefs 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((Nothing,x),t,e))) = 
+	(eextend venv (x,t), Nonrec(Vdef((Nothing,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]
+	where venv' = foldl eextend venv [(x,t) | Vdef((Nothing,x),t,_) <- vdefs]
 
     prepExp env (Var qv) = Var qv
     prepExp env (Dcon qdc) = Dcon qdc
@@ -45,12 +45,20 @@ prepModule globalEnv (Module mn tdefs vdefgs) =
     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 env@(venv,tvenv) (Let (Nonrec(Vdef((Nothing,x),t,b))) e) 
+        | kindof tvenv t == Kunlifted && suspends b =
+            -- There are two places where we call the typechecker, one of them
+            -- here.
+            -- We need to know the type of the let body in order to construct
+            -- a case expression. 
+            let eTy = typeOfExp env e in
+		Case (prepExp env b) (x,t) 
+                  eTy
+                  [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@(venv,tvenv) (Case e vb t alts) = Case (prepExp env e) vb t (map (prepAlt (eextend venv vb,tvenv)) alts)
+    prepExp env (Cast e t) = Cast (prepExp env e) t
     prepExp env (Note s e) = Note s (prepExp env e)
     prepExp env (External s t) = External s t
 
@@ -67,7 +75,7 @@ prepModule globalEnv (Module mn tdefs vdefgs) =
 	      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 =
+    unwindApp env (op@(Var(qv@(_,p)))) as | isPrimVar qv =
 	etaExpand (drop n atys) (rewindApp env op as)
         where Just atys = elookup primArgTys p
               n = length [e | Left e <- as]
@@ -75,53 +83,31 @@ prepModule globalEnv (Module mn tdefs vdefgs) =
 
 
     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)))
+	  where g e (v,t) = Lam (Vb(v,t)) (App e (Var (unqual 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
+       -- This is the other place where we call the typechecker.
+	Case (prepExp env' e2) (v,t) (typeOfExp env rhs) [Adefault rhs]
+        where rhs = (rewindApp env' (App e1 (Var (unqual v))) as)
+              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. -}
+    typeOfExp :: (Venv, Tvenv) -> Exp -> Ty
+    typeOfExp = uncurry (checkExpr mn globalEnv tdefs)
+
+    {- Return false for those expressions for which Interp.suspendExp builds 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 (Cast e _) = suspends e
     suspends (Note _ e) = suspends e
     suspends (External _ _) = False
     suspends _ = True
@@ -137,11 +123,11 @@ prepModule globalEnv (Module mn tdefs vdefgs) =
     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 =   
+    mlookup _ local_env Nothing = local_env
+    mlookup selector _  (Just m) =   
       case elookup globalEnv m of
         Just env -> selector env
-        Nothing -> error ("undefined module name: " ++ m)
+        Nothing -> error ("undefined module name: " ++ show m)
 
     qlookup ::  (Ord a, Show a) => (Envs -> Env a b) -> Env a b -> (Mname,a) -> b
     qlookup selector local_env (m,k) =