[make the newHole primitive return an IOResult to avoid putting something unboxed in a tuple, seperate out initial primitive processing from optimization. make sure no names are shadowed when expanding initial primitives. clean up E.PrimOpt
John Meacham <john@repetae.net>**20060323032647] hunk ./E/FromHs.hs 37
+import E.PrimOpt
hunk ./E/FromHs.hs 209
-        (EPi ioc (EPi tvr (ELit (LitCons n [x] _)))) | n == tc_IOResult -> Just x 
+        (EPi ioc (EPi tvr (ELit (LitCons n [x] _)))) | n == tc_IOResult -> Just x
hunk ./E/FromHs.hs 389
-        let result    = foldr ($) (EPrim (toPrim i) (map EVar es) rt) (map ELam es)
+        let result    = foldr ($) (processPrimPrim dataTable $ EPrim (toPrim i) (map EVar es) rt) (map ELam es)
hunk ./E/PrimOpt.hs 1
-module E.PrimOpt(primOpt,primOpt') where
+module E.PrimOpt(
+    primOpt',
+    processPrimPrim
+    ) where
hunk ./E/PrimOpt.hs 11
-import Support.CanType
hunk ./E/PrimOpt.hs 18
-import Support.FreeVars
hunk ./E/PrimOpt.hs 19
-import Util.NameMonad
+import Name.Names
+import Name.VConsts
hunk ./E/PrimOpt.hs 23
+import Support.CanType
+import Support.FreeVars
+import Util.NameMonad
hunk ./E/PrimOpt.hs 28
--- Some of these arn't optimizations, but rather important transformations.
-
-primOpt dataTable stats e = do
-    runStatIO stats (primOpt' dataTable e)
hunk ./E/PrimOpt.hs 51
-vars ts = [ tVr n t | t <- ts | n <- [2,4 ..]]
+vars ts = [ tVr n t | t <- ts | n <- [2,4 ..], n `notElem` fvs] where
+    fvs = freeVars ts
hunk ./E/PrimOpt.hs 67
-        primopt (PrimPrim "seq") [x,y] _  = return $ prim_seq x y
hunk ./E/PrimOpt.hs 77
+        primopt (Operator "-" [ta] tr) [ELit (LitInt x t)] rt | ta == tr && rt == t = return $ ELit (LitInt (negate x) t)
hunk ./E/PrimOpt.hs 115
-        -- negate of literal
-        primopt (Operator "-" [ta] tr) [ELit (LitInt x t)] rt | ta == tr && rt == t = return $ ELit (LitInt (negate x) t)
-        -- various primitives
+        -- cast of constant
+        primopt (CCast _ _) [ELit (LitInt x _)] t = return $ ELit (LitInt x t)  -- TODO ensure constant fits
+        primopt _ _ _ = fail "No primitive optimization to apply"
+primOpt' _  x = return x
+
+
+processPrimPrim dataTable o@(EPrim (APrim prim _) es t) = case primopt prim es t of
+            Just e -> e
+            Nothing -> o
+        where
+        primopt (PrimPrim "seq") [x,y] _  = return $ prim_seq x y
hunk ./E/PrimOpt.hs 133
-        primopt (PrimPrim "newHole__") [y] rt  = return $ EAp (ELam y' $ eCaseTup' (EPrim (primPrim "newHole_") [EVar y'] (ltTuple' [a,b])) [a',b'] (eTuple [EVar a',EVar b'])) y where
-            [y',a',b'] = vars [getType y,a,b]
-            ELit (LitCons _ [a,b] (ESort EStar)) = rt
+        primopt (PrimPrim "newHole__") [y] (ELit (LitCons name [b] (ESort EStar))) | name == tc_IOResult =
+            return $ eCaseTup' (EPrim (primPrim "newHole_") [y] (ltTuple' [tWorld__,b])) [a',b'] (eJustIO (EVar a') (EVar b')) where
+                (a':b':_) = vars [tWorld__,b,y]
hunk ./E/PrimOpt.hs 157
-        primopt (CCast _ _) [ELit (LitInt x _)] t = return $ ELit (LitInt x t)  -- TODO ensure constant fits
-        primopt _ _ _ = fail "No primitive optimization to apply"
-primOpt' _  x = return x
-
+        primopt _ _ _ = fail "not a primopt we care about"
hunk ./Main.hs 702
+    when (dodump && dump FD.Steps) $ printProgram prog
hunk ./lib/base/Jhc/Hole.hs 21
-newHole = IO $ \_ world -> case newHole__ world of
-    (world',r) -> JustIO world' r
+newHole = IO $ \_ world -> newHole__ world
hunk ./lib/base/Jhc/Hole.hs 28
-foreign import primitive newHole__  :: World__ -> (World__,Hole a)
+foreign import primitive newHole__  :: World__ -> IOResult (Hole a)