[clean up several things about grin generation. write out more grin code for debugging
John Meacham <john@repetae.net>**20070509031647] hunk ./Grin/EvalInline.hs 105
+    | null cs && argType == tyUnit = Tup [n1] :-> Error ("Empty Apply:" ++ show ts)  retType
hunk ./Grin/EvalInline.hs 107
+    | argType == tyUnit = Tup [n1] :-> Case n1 cs
hunk ./Grin/EvalInline.hs 150
+        g (App fn [fun] ty) | fn == funcApply = do
+            fn' <- runOnceMap appMap (tyUnit,ty) $ do
+                u <- newUniq
+                return (toAtom $ "@apply_" ++ show u)
+            return (App fn' [fun] ty)
hunk ./Grin/EvalInline.hs 164
+        cf ((targ,tret),name) | targ == tyUnit = ((name,appBody),(name,tyTy { tySlots = [TyNode],tyReturn = tret })) where
+            appBody = createApply targ tret (grinTypeEnv grin) tags
hunk ./Grin/FromE.hs 95
-    scMap :: Map Int (Atom,[Ty],Ty),
-    ccafMap :: Map Int Val,
+    scMap :: Map Id (Atom,[Ty],Ty),
+    ccafMap :: Map Id Val,
hunk ./Grin/FromE.hs 106
--- after pruning the E, we should not accidentally turn things into CAFs that wern't already.
-newtype IsCAF = IsCAF Bool
-    deriving(Typeable,Show,Eq)
-
hunk ./Grin/FromE.hs 129
-        f x = (x,map (toType (TyPtr TyNode) . tvrType ) $ filter (shouldKeep . getType )as,toType TyNode (getType (e::E) :: E))
+        f x = (x,map (toType (TyPtr TyNode) . tvrType )  as,toType TyNode (getType (e::E) :: E))
hunk ./Grin/FromE.hs 133
-    toty (ELit LitCons { litName = n, litArgs = es, litType = ty }) |  ty == eHash, TypeConstructor <- nameType n, Just _ <- fromUnboxedNameTuple n = (tuple (map (toType (TyPtr TyNode) ) (filter shouldKeep es)))
+    toty (ELit LitCons { litName = n, litArgs = es, litType = ty }) |  ty == eHash, TypeConstructor <- nameType n, Just _ <- fromUnboxedNameTuple n = (tuple (keepIts $ map (toType (TyPtr TyNode) ) es))
hunk ./Grin/FromE.hs 146
-    prog <- return $ prog { progCombinators  = map stripTheWorld (progCombinators prog) }
+--    prog <- return $ prog { progCombinators  = map stripTheWorld (progCombinators prog) }
hunk ./Grin/FromE.hs 175
-    --(_,(Tup [] :-> theMain)) <- doCompile ((mainEntry,[],EVar mainEntry))
-    let theMain = App (scTag mainEntry) [] tyUnit
-
hunk ./Grin/FromE.hs 215
-        theFuncs = (funcMain ,(Tup [] :-> App funcInitCafs [] tyUnit :>>= unit :->  discardResult theMain)) : efv ++ ds'
+        theFuncs = (funcMain ,Tup [] :-> App funcInitCafs [] tyUnit :>>= unit :->  discardResult (App (scTag mainEntry) [] tyUnit)) : efv ++ ds'
hunk ./Grin/FromE.hs 218
-    scMap = Map.fromList [ (tvrIdent t,toEntry x) |  x@(t,_,_) <- map stripTheWorld $ progCombinators prog]
+    scMap = Map.fromList [ (tvrIdent t,toEntry x) |  x@(t,_,_) <- progCombinators prog]
hunk ./Grin/FromE.hs 221
-    con c | keepIt = return $ (n,TyTy { tySlots = as, tyReturn = TyNode, tySiblings = fmap (map convertName) sibs}) where
+    con c | keepCon = return $ (n,TyTy { tySlots = filter keepIt as, tyReturn = TyNode, tySiblings = fmap (map convertName) sibs}) where
hunk ./Grin/FromE.hs 224
-        as = [ toType (TyPtr TyNode) s |  s <- conSlots c, shouldKeep s]
-        keepIt = isNothing (conVirtual c) || TypeConstructor == nameType (conName c)
+        as = [ toType (TyPtr TyNode) s |  s <- conSlots c]
+        keepCon = isNothing (conVirtual c) || TypeConstructor == nameType (conName c)
hunk ./Grin/FromE.hs 236
-stripTheWorld :: (TVr,[TVr],E) ->  (TVr,[TVr],E)
-stripTheWorld (t,as,e) = (tvrInfo_u (Info.insert (IsCAF caf)) t,filter (shouldKeep . getType) as,e) where
-    caf = null as
-
hunk ./Grin/FromE.hs 240
+class Keepable a where
+    keepIt :: a -> Bool
+
+--instance Keepable E where
+--    keepIt = shouldKeep
+instance Keepable Ty where
+    keepIt t = t /= tyUnit
+instance Keepable Val where
+    keepIt t = getType t /= tyUnit
hunk ./Grin/FromE.hs 250
-makePartials (fn,TyTy { tySlots = ts, tyReturn = rt }) | tagIsFunction fn, head (show fn) /= '@'  = (fn,toTyTy (ts,rt)):[(partialTag fn i,toTyTy (reverse $ drop i $ reverse ts ,TyNode)) |  i <- [0.. end] ]  where
+keepIts xs = filter keepIt xs
+
+makePartials (fn,TyTy { tySlots = ts, tyReturn = rt }) | tagIsFunction fn, head (show fn) /= '@' = ans where
+    ans = (fn,toTyTy (ts,rt)):[(partialTag fn i,toTyTy (reverse $ drop i $ reverse ts ,TyNode)) |  i <- [0.. end] ]
hunk ./Grin/FromE.hs 260
-    (convertName tc_Absurd, ([],TyNode)),
hunk ./Grin/FromE.hs 270
+--
+-- takes a program and returns (cafs which are actually constants,which are recursive,rest of cafs)
hunk ./Grin/FromE.hs 276
-    ecafs = [ (v,e) | (v,[],e) <- ds, Just (IsCAF True) == Info.lookup (tvrInfo v) ]
+    ecafs = [ (v,e) | (v,[],e) <- ds ]
hunk ./Grin/FromE.hs 289
-    conv (ELit lc@LitCons { litName = n, litArgs = es }) | Just nn <- getName lc = (Const (NodeC nn (map conv es)))
+    conv (ELit lc@LitCons { litName = n, litArgs = es }) | Just nn <- getName lc = (Const (NodeC nn (keepIts $ map conv es)))
hunk ./Grin/FromE.hs 292
-    conv e | (EVar x,as) <- fromAp e, Just vs <- Map.lookup x res, vs > length (ff as) = Const (NodeC (partialTag (scTag x) (vs - length (ff as))) (map conv (ff as)))
+    conv e | (EVar x,as) <- fromAp e, Just vs <- Map.lookup x res, vs > length (ff as) = Const (NodeC (partialTag (scTag x) (vs - length (ff as))) (keepIts $ map conv (ff as)))
hunk ./Grin/FromE.hs 297
-    ff x = filter (shouldKeep . getType) x
+
+    ff x = x
+    --ff x = filter (shouldKeep . getType) x
hunk ./Grin/FromE.hs 322
---doApply x y ty | getType y == tyUnit = App funcApply [x] ty
+doApply x y ty | not (keepIt y) = App funcApply [x] ty
hunk ./Grin/FromE.hs 345
-        return (nn,(Tup (map toVal (filter (shouldKeep . getType) as)) :-> x))
+        return (nn,(Tup (filter keepIt $ map toVal as) :-> x))
hunk ./Grin/FromE.hs 367
-                    app fty (App v x rt) y
+                    app fty (App v (filter keepIt x) rt) y
hunk ./Grin/FromE.hs 372
-                        app fty (App v x es) y
+                        app fty (App v (filter keepIt x) es) y
hunk ./Grin/FromE.hs 375
-                        return $ Return (NodeC pt as)
+                        return $ Return (NodeC pt (filter keepIt as))
hunk ./Grin/FromE.hs 445
-        Func True fn as "void" -> return $ Prim prim { primType = ((map (Ty . toAtom) as),tyUnit) } (args $ tail xs)
+        Func True fn as "void" -> return $ Prim prim { primType = (keepIts (map (Ty . toAtom) as),tyUnit) } (args $ tail xs)
hunk ./Grin/FromE.hs 447
-            let p = prim { primType = ((map (Ty . toAtom) as),Ty (toAtom r)) }
+            let p = prim { primType = (keepIts (map (Ty . toAtom) as),Ty (toAtom r)) }
hunk ./Grin/FromE.hs 449
-            return $ Prim p (args $ tail xs)
+            return $ Prim p (filter keepIt $ args $ tail xs)
hunk ./Grin/FromE.hs 451
-            let p = prim { primType = ((map (Ty . toAtom) as),Ty (toAtom r)) }
-            return $ Prim p (args xs)
+            let p = prim { primType = (keepIts (map (Ty . toAtom) as),Ty (toAtom r)) }
+            return $ Prim p (filter keepIt $ args xs)
hunk ./Grin/FromE.hs 481
-        return $ e :>>= tuple (map toVal (filter (shouldKeep . getType) xs)) :-> wh
+        return $ e :>>= tuple (filter keepIt $ map toVal xs) :-> wh
hunk ./Grin/FromE.hs 523
-        return (NodeC nn (map toVal (filter (shouldKeep . getType) es)) :-> x)
+        return (NodeC nn (filter keepIt $ map toVal es) :-> x)
hunk ./Grin/FromE.hs 533
+    app ty e [a] | not (keepIt a) = do
+        v <- newNodeVar
+        return (e :>>= v :-> App funcApply [v] ty)
hunk ./Grin/FromE.hs 539
+    app ty e (a:as) | not (keepIt a) = do
+        v <- newNodeVar
+        app ty (e :>>= v :-> App funcApply [v] TyNode) as
hunk ./Grin/FromE.hs 545
+
hunk ./Grin/FromE.hs 547
-    app' (Const (NodeC t cs)) (a:as) | tagIsPartialAp t = do
-        let Just (n,frs) = tagUnfunction t
-            lazy = do
-                mtick "Grin.FromE.lazy-app-const"
-                app' (Const (NodeC (partialTag frs (n - 1)) (cs ++ [a]))) as
-        case a of
-            Const {} -> lazy
-            Lit {} -> lazy
-            Var (V n) _ | n < 0 -> lazy
-            _ -> do
-                mtick "Grin.FromE.lazy-app-store"
-                tpv <- newNodePtrVar
-                x <- app' tpv as
-                return $ Store  (NodeC (partialTag frs (n - 1)) (cs ++ [a])) :>>= tpv :-> x
+--    app' (Const (NodeC t cs)) (a:as) | tagIsPartialAp t = do
+--        let Just (n,frs) = tagUnfunction t
+--            lazy = do
+--                mtick "Grin.FromE.lazy-app-const"
+--                app' (Const (NodeC (partialTag frs (n - 1)) (cs ++ [a]))) as
+--        case a of
+--            Const {} -> lazy
+--            Lit {} -> lazy
+--            Var (V n) _ | n < 0 -> lazy
+--            _ -> do
+--                mtick "Grin.FromE.lazy-app-store"
+--                tpv <- newNodePtrVar
+--                x <- app' tpv as
+--                return $ Store  (NodeC (partialTag frs (n - 1)) (cs ++ [a])) :>>= tpv :-> x
hunk ./Grin/FromE.hs 566
-            args = [Var v ty | v <- [v1..] | ty <- (TyPtr TyNode:map getType as)]
-            s = Store (NodeC t (e:as))
-        d <- app TyNode (gEval p1) (tail args) --TODO
-        liftIO $ addNewFunction cenv (tl,Tup (args) :-> d)
+            targs = [Var v ty | v <- [v1..] | ty <- (TyPtr TyNode:map getType as)]
+            s = Store (NodeC t (filter keepIt $ e:as))
+        d <- app TyNode (gEval p1) (tail targs)
+        liftIO $ addNewFunction cenv (tl,Tup (filter keepIt targs) :-> d)
hunk ./Grin/FromE.hs 599
-                    let s = Store (NodeC (partialTag v 0) x)
+                    let s = Store (NodeC (partialTag v 0) (filter keepIt x))
hunk ./Grin/FromE.hs 603
-                | length as < length as', all valIsConstant as -> do
-                    let pt = partialTag v (length as' - length as)
-                    mtick "Grin.FromE.partial-constant"
-                    return $ Return (Const (NodeC pt as))
+--                | length as < length as', all valIsConstant as -> do
+--                    let pt = partialTag v (length as' - length as)
+--                    mtick "Grin.FromE.partial-constant"
+--                    return $ Return (Const (NodeC pt as))
hunk ./Grin/FromE.hs 609
-                    return $ if all valIsConstant as then
-                        Return (Const (NodeC pt as))
-                            else Store (NodeC pt as)
+                    as <- return $ filter keepIt as
+                    return $ if all valIsConstant as
+                      then Return (Const (NodeC pt as))
+                      else Store (NodeC pt as)
hunk ./Grin/FromE.hs 614
-                    return $ Store (NodeC (tagFlipFunction v) as)
+                    return $ Store (NodeC (tagFlipFunction v) (filter keepIt as))
hunk ./Grin/FromE.hs 639
-                    return $ [createFuncDef True nn (Tup (map toVal (filter (shouldKeep . getType) as)) :-> x)]
+                    return $ [createFuncDef True nn (Tup (filter keepIt $ map toVal as) :-> x)]
hunk ./Grin/FromE.hs 666
-    args es = map f (filter (shouldKeep . getType) es) where
+    args es = map f es where
hunk ./Grin/FromE.hs 688
-    constant (ELit lc@LitCons { litName = n, litArgs = es }) | Just es <- mapM constant (filter (shouldKeep . getType) es), Just nn <- getName lc = (return $ Const (NodeC nn es))
+    constant (ELit lc@LitCons { litName = n, litArgs = es }) | Just es <- mapM constant es, Just nn <- getName lc = (return $ Const (NodeC nn (filter keepIt es)))
hunk ./Grin/FromE.hs 699
-            return (tuple (args (filter (shouldKeep . getType) es)))
+            return (tuple (keepIts $ args es))
hunk ./Grin/FromE.hs 701
-            return (NodeC cn (args es))
+            return (NodeC cn (keepIts $ args es))
hunk ./Grin/FromE.hs 703
-            return (NodeC (partialTag cn (nargs - length es)) $ args es)
+            return (NodeC (partialTag cn (nargs - length es)) $ keepIts (args es))
hunk ./Grin/FromE.hs 728
+literal (ELit LitCons { litName = n, litArgs = xs })  |  Just xs <- mapM literal xs, Just _ <- fromUnboxedNameTuple n = return (tuple $ keepIts xs)
hunk ./Grin/Show.hs 91
+prettyExp vl (App t [a] _) | t == funcApply = vl <> keyword "apply" <+> prettyVal a
hunk ./Main.hs 693
+        dumpGrin (optOutName options) "initial" x
hunk ./Main.hs 699
+        dumpGrin (optOutName options) "normalized" x
hunk ./Main.hs 782
+dumpGrin fname pname grin = do
+    h <- openFile (fname ++ "_" ++ pname ++ ".grin") WriteMode
+    (argstring,sversion) <- getArgString
+    hPutStrLn h $ unlines [ "-- " ++ argstring,"-- " ++ sversion,""]
+    hPrintGrin h grin
+    hClose h
+
+