[represent unit values in WHNF by a raw value rather than a pointer
John Meacham <john@repetae.net>**20070228050017] hunk ./C/FromGrin2.hs 126
-convertVal (Const (NodeC h _)) | h == tagHole = return nullPtr
+convertVal (Const (NodeC h _)) | h == tagHole = return (cast sptr_t (f_VALUE (constant $ number 0)))
hunk ./C/FromGrin2.hs 128
-    (_,i) <- newConst h
-    return $ variable (name $  'c':show i )
-convertVal h@NodeC {} | valIsConstant h = do
-    (_,i) <- newConst h
-    return $ variable (name $  'c':show i )
+    tyenv <- asks (grinTypeEnv . rGrin)
+    case h of
+        NodeC a ts | Just bn <- basicNode tyenv a ts -> return (cast sptr_t bn)
+        _ -> do
+            (_,i) <- newConst h
+            return $ variable (name $  'c':show i )
+convertVal h@(NodeC a ts) | valIsConstant h = do
+    tyenv <- asks (grinTypeEnv . rGrin)
+    case basicNode tyenv a ts of
+        Just bn -> return bn
+        _ -> do
+            (_,i) <- newConst h
+            return $ variable (name $  'c':show i )
hunk ./C/FromGrin2.hs 493
+    tyenv <- asks (grinTypeEnv . rGrin)
hunk ./C/FromGrin2.hs 495
-    st <- nodeType t
-    as' <- mapM convertVal as
-    tmp <- newVar (if sf then sptr_t else wptr_t)
-    let tmp' = concrete t tmp
-        wmalloc = if not sf && all (nonPtr . getType) as then jhc_malloc_atomic else jhc_malloc
-        malloc =  tmp =* wmalloc (sizeof st)
-        ass = [ if isValUnknown aa then mempty else project' i tmp' =* a | a <- as' | aa <- as | i <- map arg [(1 :: Int) ..] ]
-        nonPtr TyPtr {} = False
-        nonPtr TyNode = False
-        nonPtr (TyTup xs) = all nonPtr xs
-        nonPtr _ = True
-    tagassign <- tagAssign tmp' t
-    let res = if sf then (f_EVALTAG tmp) else tmp
-    return (mconcat $ malloc:tagassign:ass,res)
+    case basicNode tyenv t as of
+      Just e -> return (mempty,e)
+      Nothing -> do
+        st <- nodeType t
+        as' <- mapM convertVal as
+        tmp <- newVar (if sf then sptr_t else wptr_t)
+        let tmp' = concrete t tmp
+            wmalloc = if not sf && all (nonPtr . getType) as then jhc_malloc_atomic else jhc_malloc
+            malloc =  tmp =* wmalloc (sizeof st)
+            ass = [ if isValUnknown aa then mempty else project' i tmp' =* a | a <- as' | aa <- as | i <- map arg [(1 :: Int) ..] ]
+            nonPtr TyPtr {} = False
+            nonPtr TyNode = False
+            nonPtr (TyTup xs) = all nonPtr xs
+            nonPtr _ = True
+        tagassign <- tagAssign tmp' t
+        let res = if sf then (f_EVALTAG tmp) else tmp
+        return (mconcat $ malloc:tagassign:ass,res)
hunk ./C/FromGrin2.hs 563
-    tell mempty { wStructures = Map.singleton (nodeStructName n) (tag ++ zip [ name $ 'a':show i | i <-  [1 ..] ] ts') }
+        fields = (tag ++ zip [ name $ 'a':show i | i <-  [1 ..] ] ts')
+    unless (null fields) $ tell mempty { wStructures = Map.singleton (nodeStructName n) fields }
+
+
+basicNode :: TyEnv -> Atom -> [Val] -> (Maybe Expression)
+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
+
hunk ./C/FromGrin2.hs 633
+f_VALUE e     = functionCall (name "VALUE") [e]
+f_ISVALUE e   = functionCall (name "ISVALUE") [e]
hunk ./C/FromGrin2.hs 701
-    toStatement e = expr e
+    toStatement x = expr x
+
+class ToExpression a where
+    toExpression :: a -> Expression
+
+instance ToExpression Expression where
+    toExpression e = e
+
+instance ToExpression Constant where
+    toExpression c = constant c
+
+instance ToExpression Name where
+    toExpression c = variable c
+
hunk ./C/Generate.hs 18
+    Constant(),
hunk ./data/jhc_rts2.c 12
+#define VALUE(n)    ((wptr_t)(((uintptr_t)(n) << 2) | P_VALUE))
+#define ISVALUE(n)  (assert(!ISLAZY(n)), ((uintptr_t)(n) & 0x2))