[make convertVal a local definition, start adding support for embedded primitives
John Meacham <john@repetae.net>**20080322214028] hunk ./C/FromGrin2.hs 17
-import StringTable.Atom
hunk ./C/FromGrin2.hs 21
+import Cmm.Number
hunk ./C/FromGrin2.hs 26
-import Grin.Show()
hunk ./C/FromGrin2.hs 27
+import Grin.Show()
hunk ./C/FromGrin2.hs 31
+import StringTable.Atom
hunk ./C/FromGrin2.hs 166
-convertVal v | Just e <- convertConst v = e
-convertVal (Var v ty) = fetchVar v ty
-convertVal (Const h) = do
-    tyenv <- asks (grinTypeEnv . rGrin)
-    case h of
-        NodeC a ts -> do
-            bn <- basicNode tyenv a ts
-            case bn of
-                Just bn ->  return (cast sptr_t bn)
-                _ -> do
-                    (_,i) <- newConst h
-                    return $ variable (name $  'c':show i )
-        _ -> do
-            (_,i) <- newConst h
-            return $ variable (name $  'c':show i )
-convertVal h@(NodeC a ts) | valIsConstant h = do
-    tyenv <- asks (grinTypeEnv . rGrin)
-    bn <- basicNode tyenv a ts
-    case bn of
-        Just bn -> return bn
-        _ -> do
-            (_,i) <- newConst h
-            return $ f_PROMOTE (variable (name $  'c':show i ))
+convertVal v = cvc v where
+    cvc v = convertConst v >>= maybe (cv v) return
+    cv (Var v ty) = fetchVar v ty
+    cv (Const h) = do
+        case h of
+            NodeC a ts -> do
+                bn <- basicNode a ts
+                case bn of
+                    Just bn ->  return (cast sptr_t bn)
+                    _ -> do
+                        (_,i) <- newConst h
+                        return $ variable (name $  'c':show i )
+            _ -> do
+                (_,i) <- newConst h
+                return $ variable (name $  'c':show i )
+    cv h@(NodeC a ts) | valIsConstant h = do
+        bn <- basicNode a ts
+        case bn of
+            Just bn -> return bn
+            _ -> do
+                (_,i) <- newConst h
+                return $ f_PROMOTE (variable (name $  'c':show i ))
hunk ./C/FromGrin2.hs 189
-convertVal (ValPrim (APrim p _) [x] (TyPrim opty)) = do
-    x' <- convertVal x
-    case p of
-        Op (Op.UnOp n ta) r -> primUnOp n ta r x'
-        Op (Op.ConvOp n ta) r -> return $ castFunc n ta r x'
-        x -> return $ err ("convertVal: " ++ show x)
-convertVal (ValPrim (APrim p _) [x,y] _) = do
-    x' <- convertVal x
-    y' <- convertVal y
-    case p of
-        Op (Op.BinOp n ta tb) r -> primBinOp n ta tb r x' y'
-        x -> return $ err ("convertVal: " ++ show x)
+    cv (ValPrim (APrim p _) [x] (TyPrim opty)) = do
+        x' <- convertVal x
+        case p of
+            Op (Op.UnOp n ta) r -> primUnOp n ta r x'
+            Op (Op.ConvOp n ta) r -> return $ castFunc n ta r x'
+            x -> return $ err ("convertVal: " ++ show x)
+    cv (ValPrim (APrim p _) [x,y] _) = do
+        x' <- convertVal x
+        y' <- convertVal y
+        case p of
+            Op (Op.BinOp n ta tb) r -> primBinOp n ta tb r x' y'
+            x -> return $ err ("convertVal: " ++ show x)
hunk ./C/FromGrin2.hs 202
-convertVal x = return $ err ("convertVal: " ++ show x)
+    cv x = return $ err ("convertVal: " ++ show x)
hunk ./C/FromGrin2.hs 531
-        f (Left v) a = text ".a" <> tshow a <+> text "=" <+> text (show $ drawG (fst3 $ runC grin e)) where
-            Just e = convertConst v
+        f (Left v) a = text ".a" <> tshow a <+> text "=" <+> text (show $ drawG e) where
+            Just e = fst3 . runC grin $ convertConst v
hunk ./C/FromGrin2.hs 534
-convertConst :: Val -> Maybe (C Expression)
-convertConst (Const (NodeC n [])) = Just $ do tellTags n ; return (cast sptr_t $ f_RAWWHAT (constant $ enum (nodeTagName n)))
-convertConst (NodeC n []) | not (tagIsSuspFunction n)  = Just $ do tellTags n ;  return (f_RAWWHAT (constant $ enum (nodeTagName n)))
-convertConst v = fmap return (f v) where
+convertConst :: Val -> C (Maybe Expression)
+convertConst (NodeC n as) = basicNode n as
+convertConst (Const (NodeC n as)) = fmap (fmap $ cast sptr_t) $ basicNode n as
+convertConst v = return (f v) where
hunk ./C/FromGrin2.hs 677
-    tyenv <- asks (grinTypeEnv . rGrin)
hunk ./C/FromGrin2.hs 678
-    bn <- basicNode tyenv t as
+    bn <- basicNode t as
hunk ./C/FromGrin2.hs 722
-basicNode :: TyEnv -> Atom -> [Val] -> C (Maybe Expression)
-basicNode tyenv a [] | not (tagIsSuspFunction a) = do tellTags a ; return . Just $ (f_RAWWHAT (constant $ enum (nodeTagName a)))
-basicNode _ _ _ = return Nothing
-{-
-basicNode tyenv a [] | isJust s = ans where
-    Just TyTy { tySiblings = s@(~(Just ss)) } = findTyTy tyenv a
-    ans = case ss of
-        [n'] | n' == a -> Just (f_VALUE (constant $ number 0))
-        _ -> Nothing
-basicNode _ _ _ = Nothing
--}
+basicNode :: Atom -> [Val] -> C (Maybe Expression)
+basicNode a _ | tagIsSuspFunction a = return Nothing
+basicNode a []  = do tellTags a ; return . Just $ (f_RAWWHAT (constant $ enum (nodeTagName a)))
+basicNode a [Lit v ty] = do
+    tyenv <- asks (grinTypeEnv . rGrin)
+    return $ do
+        TyTy { tySiblings = s } <- findTyTy tyenv a
+        [n'] <- s
+        guard $ n' == a
+        b <- Op.cmmTyBits ty
+        guard $ b <= 30
+        Op.HintNone <- Op.cmmTyHint ty
+        v <- toIntegral v
+        Just (f_VALUE (constant $ number v))
+basicNode _ _ = return Nothing
hunk ./C/FromGrin2.hs 738
+instance Op.ToCmmTy Ty where
+    toCmmTy (TyPrim p) = Just p
+    toCmmTy _ = Nothing
hunk ./C/FromGrin2.hs 775
+f_VALUE e     = functionCall (name "VALUE") [e]