[make E->Grin conversion support unboxed values
John Meacham <john@repetae.net>**20051003113947] hunk ./E/SSimplify.hs 94
-                | t `Set.member` cycNodes = NoStrict
-                | Just (Strict.S _) <- Map.lookup (tvrNum t) (so_strictness sopts) = Strict
-                | otherwise = NoStrict
+                | t `Set.member` cycNodes = Strict.L
+                | Just s <- Map.lookup (tvrNum t) (so_strictness sopts) = s
+                | otherwise = Strict.L
hunk ./Grin/FromE.hs 105
-        f x = (x,map (toty (TyPtr TyNode) . tvrType ) as,toty TyNode (getType (e::E) :: E))
-        toty node (ELit (LitCons n [] es)) |  es == eHash, RawType <- nameType n = (Ty $ toAtom (show n))
-        toty node _ = node
+        f x = (x,map (toType (TyPtr TyNode) . tvrType ) as,toType TyNode (getType (e::E) :: E))
hunk ./Grin/FromE.hs 107
+toType :: Ty -> E -> Ty
+toType node = toty where
+    toty (ELit (LitCons n es ty)) |  ty == eHash, TypeConstructor <- nameType n, Just _ <- fromUnboxedNameTuple n = (TyTup (map (toType (TyPtr TyNode) ) es))
+    toty (ELit (LitCons n [] es)) |  es == eHash, RawType <- nameType n = (Ty $ toAtom (show n))
+    toty _ = node
hunk ./Grin/FromE.hs 238
+    | Just _ <- fromUnboxedNameTuple n = fail $ "unboxed tuples don't have names silly"
hunk ./Grin/FromE.hs 270
-compile' dataTable cenv (tvr,as,e) = cr e >>= \x -> return (nn,(Tup (map toVal as) :-> x)) where
+compile' dataTable cenv (tvr,as,e) = ans where
+    ans = do
+        --putStrLn $ "Compiling: " ++ show nn
+        x <- cr e
+        return (nn,(Tup (map toVal as) :-> x))
hunk ./Grin/FromE.hs 280
-    ce (EError s e) = return (Error s TyNode)
+    ce (EError s e) = return (Error s (toType TyNode e))
hunk ./Grin/FromE.hs 444
-    ce (ECase e _ [Alt (LitCons n xs _) wh] Nothing) | Just _ <- fromUnboxedNameTuple n = do
+    ce (ECase e _ [Alt (LitCons n xs _) wh] _) | Just _ <- fromUnboxedNameTuple n, DataConstructor <- nameType n  = do
hunk ./Grin/FromE.hs 505
---    cp (PatWildCard,ELam tvr e) = do
---        x <- ce e
---        v <- newNodeVar
---        return (v :-> Store v :>>= toVal tvr :-> x)
---    cp (PatWildCard,e) = do
---        x <- ce e
---        v <- newNodeVar
---        w <- newNodePtrVar
---        m <- newNodeVar
---        return (v :-> Store v :>>= w :-> x :>>= m :-> gApply m w)
+    cp (Alt lc@(LitCons n es _) e) | Just v <- fromUnboxedNameTuple n, DataConstructor <- nameType n = do
+        putStrLn $ "Print alt: " ++ show lc
+        x <- ce e
+        return (Tup (map toVal es) :-> x)
hunk ./Grin/FromE.hs 607
-        --rb <- typecheck tenv body
-        let addt (TyEnv mp) =  TyEnv $ Map.insert n (args',TyNode) mp
+        rb <- typecheck tenv body
+        let addt (TyEnv mp) =  TyEnv $ Map.insert n (args',rb) mp
hunk ./Grin/FromE.hs 730
+--    constant (ELit lc@(LitCons n es _)) | Just es <- mapM constant es, Just _ <- fromUnboxedNameTuple n, DataConstructor <- nameType n = (return $ Const (Tup es))
hunk ./Grin/FromE.hs 767
+        | Just v <- fromUnboxedNameTuple n, DataConstructor <- nameType n = do
+            return (Tup (args es))
hunk ./Grin/Grin.hs 440
-same msg t1 t2 = fail $ "Types not the same:" <+> msg <+> tshow t1 <+> tshow t2
+same msg t1 t2 = fail $ "Types not the same:" <+> parens msg <+> parens (tshow t1) <+> parens (tshow t2)