{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-unused-matches #-}
{-# OPTIONS_GHC -fno-warn-unused-binds #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
-- The above warning suppression flags are a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
--     http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details
module Main(main) where

#include "../../includes/ghcconfig.h"
#include "../../includes/stg/HaskellMachRegs.h"
#include "../../includes/rts/Constants.h"

-- Needed for TAG_BITS
#include "../../includes/MachDeps.h"

import Prelude hiding ((<>))

import Text.PrettyPrint
import Data.Word
import Data.Bits
import Data.List        ( intersperse, nub, sort )
import System.Exit
import System.Environment
import System.IO
import Control.Arrow ((***))

-- -----------------------------------------------------------------------------
-- Argument kinds (rougly equivalent to PrimRep)

data ArgRep
  = N   -- non-ptr
  | P   -- ptr
  | V   -- void
  | F   -- float
  | D   -- double
  | L   -- long (64-bit)
  | V16 -- 16-byte (128-bit) vectors
  | V32 -- 32-byte (256-bit) vectors
  | V64 -- 64-byte (512-bit) vectors

-- size of a value in *words*
argSize :: ArgRep -> Int
argSize N   = 1
argSize P   = 1
argSize V   = 0
argSize F   = 1
argSize D   = (SIZEOF_DOUBLE `quot` SIZEOF_VOID_P :: Int)
argSize L   = (8 `quot` SIZEOF_VOID_P :: Int)
argSize V16 = (16 `quot` SIZEOF_VOID_P :: Int)
argSize V32 = (32 `quot` SIZEOF_VOID_P :: Int)
argSize V64 = (64 `quot` SIZEOF_VOID_P :: Int)

showArg :: ArgRep -> String
showArg N   = "n"
showArg P   = "p"
showArg V   = "v"
showArg F   = "f"
showArg D   = "d"
showArg L   = "l"
showArg V16 = "v16"
showArg V32 = "v32"
showArg V64 = "v64"

-- is a value a pointer?
isPtr :: ArgRep -> Bool
isPtr P = True
isPtr _ = False

-- -----------------------------------------------------------------------------
-- Registers

data RegStatus = Registerised | Unregisterised

type Reg = String

availableRegs :: RegStatus -> ([Reg],[Reg],[Reg],[Reg])
availableRegs Unregisterised = ([],[],[],[])
availableRegs Registerised =
  ( vanillaRegs MAX_REAL_VANILLA_REG,
    floatRegs   MAX_REAL_FLOAT_REG,
    doubleRegs  MAX_REAL_DOUBLE_REG,
    longRegs    MAX_REAL_LONG_REG
  )

vanillaRegs, floatRegs, doubleRegs, longRegs :: Int -> [Reg]
vanillaRegs n = [ "R" ++ show m | m <- [2..n] ]  -- never use R1
floatRegs   n = [ "F" ++ show m | m <- [1..n] ]
doubleRegs  n = [ "D" ++ show m | m <- [1..n] ]
longRegs    n = [ "L" ++ show m | m <- [1..n] ]

-- -----------------------------------------------------------------------------
-- Loading/saving register arguments to the stack

loadRegArgs :: RegStatus -> Int -> [ArgRep] -> (Doc,Int)
loadRegArgs regstatus sp args
 = (loadRegOffs reg_locs, sp')
 where (reg_locs, _, sp') = assignRegs regstatus sp args

loadRegOffs :: [(Reg,Int)] -> Doc
loadRegOffs = vcat . map (uncurry assign_stk_to_reg)

saveRegOffs :: [(Reg,Int)] -> Doc
saveRegOffs = vcat . map (uncurry assign_reg_to_stk)

assignRegs
        :: RegStatus            -- are we registerised?
        -> Int                  -- Sp of first arg
        -> [ArgRep]             -- args
        -> ([(Reg,Int)],        -- regs and offsets to load
            [ArgRep],           -- left-over args
            Int)                -- Sp of left-over args
assignRegs regstatus sp args = assign sp args (availableRegs regstatus) []

assign sp [] regs doc = (doc, [], sp)
assign sp (V : args) regs doc = assign sp args regs doc
assign sp (arg : args) regs doc
 = case findAvailableReg arg regs of
    Just (reg, regs') -> assign (sp + argSize arg)  args regs'
                            ((reg, sp) : doc)
    Nothing -> (doc, (arg:args), sp)

findAvailableReg N (vreg:vregs, fregs, dregs, lregs) =
  Just (vreg, (vregs,fregs,dregs,lregs))
findAvailableReg P (vreg:vregs, fregs, dregs, lregs) =
  Just (vreg, (vregs,fregs,dregs,lregs))
findAvailableReg F (vregs, freg:fregs, dregs, lregs) =
  Just (freg, (vregs,fregs,dregs,lregs))
findAvailableReg D (vregs, fregs, dreg:dregs, lregs) =
  Just (dreg, (vregs,fregs,dregs,lregs))
findAvailableReg L (vregs, fregs, dregs, lreg:lregs) =
  Just (lreg, (vregs,fregs,dregs,lregs))
findAvailableReg _ _ = Nothing

assign_reg_to_stk reg sp
   = loadSpWordOff (regRep reg) sp <> text " = " <> text reg <> semi

assign_stk_to_reg reg sp
   = text reg <> text " = " <> loadSpWordOff (regRep reg) sp <> semi

regRep ('F':_) = "F_"
regRep ('D':_) = "D_"
regRep ('L':_) = "L_"
regRep _       = "W_"

loadSpWordOff :: String -> Int -> Doc
loadSpWordOff rep off = text rep <> text "[Sp+WDS(" <> int off <> text ")]"

-- Make a jump
mkJump :: RegStatus -- Registerised status
       -> Doc       -- Jump target
       -> [Reg]     -- Registers that are definitely live
       -> [ArgRep]  -- Jump arguments
       -> Doc
mkJump regstatus jump live args =
    text "jump" <+> jump <+> brackets (hcat (punctuate comma liveRegs))
  where
    liveRegs = mkJumpLiveRegs regstatus live args

-- Make a jump, saving CCCS and restoring it on return
mkJumpSaveCCCS :: RegStatus -- Registerised status
               -> Doc       -- Jump target
               -> [Reg]     -- Registers that are definitely live
               -> [ArgRep]  -- Jump arguments
               -> Doc
mkJumpSaveCCCS regstatus jump live args =
    text "jump_SAVE_CCCS" <> parens (hcat (punctuate comma (jump : liveRegs)))
  where
    liveRegs = mkJumpLiveRegs regstatus live args

-- Calculate live registers for a jump
mkJumpLiveRegs :: RegStatus -- Registerised status
               -> [Reg]     -- Registers that are definitely live
               -> [ArgRep]  -- Jump arguments
               -> [Doc]
mkJumpLiveRegs regstatus live args =
    map text regs
  where
    (reg_locs, _, _) = assignRegs regstatus 0 args
    regs             = (nub . sort) (live ++ map fst reg_locs)

-- make a ptr/non-ptr bitmap from a list of argument types
mkBitmap :: [ArgRep] -> Word32
mkBitmap args = foldr f 0 args
 where f arg bm | isPtr arg = bm `shiftL` 1
                | otherwise = (bm `shiftL` size) .|. ((1 `shiftL` size) - 1)
                where size = argSize arg

-- -----------------------------------------------------------------------------
-- Generating the application functions

-- A SUBTLE POINT about stg_ap functions (can't think of a better
-- place to put this comment --SDM):
--
-- The entry convention to an stg_ap_ function is as follows: all the
-- arguments are on the stack (we might revisit this at some point,
-- but it doesn't make any difference on x86), and THERE IS AN EXTRA
-- EMPTY STACK SLOT at the top of the stack.
--
-- Why?  Because in several cases, stg_ap_* will need an extra stack
-- slot, eg. to push a return address in the THUNK case, and this is a
-- way of pushing the stack check up into the caller which is probably
-- doing one anyway.  Allocating the extra stack slot in the caller is
-- also probably free, because it will be adjusting Sp after pushing
-- the args anyway (this might not be true of register-rich machines
-- when we start passing args to stg_ap_* in regs).

mkApplyName args
  = text "stg_ap_" <> text (concatMap showArg args)

mkApplyRetName args
  = mkApplyName args <> text "_ret"

mkApplyFastName args
  = mkApplyName args <> text "_fast"

mkApplyInfoName args
  = mkApplyName args <> text "_info"

mb_tag_node arity | Just tag <- tagForArity arity = mkTagStmt tag <> semi
                  | otherwise = empty

mkTagStmt tag = text ("R1 = R1 + "++ show tag)

type StackUsage = (Int, Int)  -- PROFILING, normal

maxStack :: [StackUsage] -> StackUsage
maxStack = (maximum *** maximum) . unzip

stackCheck
   :: RegStatus  -- Registerised status
   -> [ArgRep]
   -> Bool       -- args in regs?
   -> Doc        -- fun_info_label
   -> StackUsage
   -> Doc
stackCheck regstatus args args_in_regs fun_info_label (prof_sp, norm_sp) =
  let
     (reg_locs, leftovers, sp_offset) = assignRegs regstatus 1 args

     cmp_sp n
       | n > 0 =
          text "if (Sp - WDS(" <> int n <> text ") < SpLim) {" $$
          nest 4 (vcat [
            if args_in_regs
               then
                 text "Sp_adj" <> parens (int (-sp_offset)) <> semi $$
                 saveRegOffs reg_locs
               else
                 empty,
            text "Sp(0) = " <> fun_info_label <> char ';',
            mkJump regstatus (text "__stg_gc_enter_1") ["R1"] [] <> semi
            ]) $$
          char '}'
       | otherwise = empty
  in
  vcat [ text "#if defined(PROFILING)",
         cmp_sp prof_sp,
         text "#else",
         cmp_sp norm_sp,
         text "#endif"
       ]

genMkPAP :: RegStatus -- Register status
         -> String    -- Macro
         -> String    -- Jump target
         -> [Reg]     -- Registers that are definitely live
         -> String    -- Ticker
         -> String    -- Disamb
         -> Bool      -- Don't load argument registers before jump if True
         -> Bool      -- Arguments already in registers if True
         -> Bool      -- Is a PAP if True
         -> [ArgRep]  -- Arguments
         -> Int       -- Size of all arguments
         -> Doc       -- info label
         -> Bool      -- Is a function
         -> (Doc, StackUsage)
genMkPAP regstatus macro jump live ticker disamb
        no_load_regs    -- don't load argument regs before jumping
        args_in_regs    -- arguments are already in regs
        is_pap args all_args_size fun_info_label
        is_fun_case
  = (doc, stack_usage)

  where
    doc = vcat smaller_arity_doc $$ exact_arity_case $$ larger_arity_doc

    stack_usage = maxStack (larger_arity_stack : smaller_arity_stack)

    n_args = length args

        -- offset of arguments on the stack at slow apply calls.
    stk_args_slow_offset = 1

    stk_args_offset
        | args_in_regs = 0
        | otherwise    = stk_args_slow_offset

-- The SMALLER ARITY cases:
--      if (arity == 1) {
--          Sp[0] = Sp[1];
--          Sp[1] = (W_)&stg_ap_1_info;
--          JMP_(GET_ENTRY(R1.cl));
    (smaller_arity_doc, smaller_arity_stack)
       = unzip [ smaller_arity i | i <- [1..n_args-1] ]

    smaller_arity arity = (doc, stack_usage)
      where
        (save_regs, stack_usage)
          | overflow_regs = save_extra_regs
          | otherwise     = shuffle_extra_args

        doc =
           text "if (arity == " <> int arity <> text ") {" $$
           nest 4 (vcat [
           --  text "TICK_SLOW_CALL_" <> text ticker <> text "_TOO_MANY();",

                -- load up regs for the call, if necessary
             load_regs,

                -- If we have more args in registers than are required
                -- for the call, then we must save some on the stack,
                -- and set up the stack for the follow-up call.
                -- If the extra arguments are on the stack, then we must
                -- instead shuffle them down to make room for the info
                -- table for the follow-on call.
             save_regs,

                -- for a PAP, we have to arrange that the stack contains a
                -- return address in the event that stg_PAP_entry fails its
                -- heap check.  See stg_PAP_entry in Apply.cmm for details.
             if is_pap
                then text "R2 = " <> mkApplyInfoName this_call_args <> semi

                else empty,
            if is_fun_case then mb_tag_node arity else empty,
            if overflow_regs
                then mkJumpSaveCCCS
                       regstatus (text jump) live (take arity args) <> semi
                else mkJump regstatus (text jump) live (if no_load_regs then [] else args) <> semi
            ]) $$
           text "}"

           -- offsets in case we need to save regs:
        (reg_locs, _, _)
           = assignRegs regstatus stk_args_offset args

           -- register assignment for *this function call*
        (reg_locs', reg_call_leftovers, reg_call_sp_stk_args)
           = assignRegs regstatus stk_args_offset (take arity args)

        load_regs
           | no_load_regs || args_in_regs = empty
           | otherwise                    = loadRegOffs reg_locs'

        (this_call_args, rest_args) = splitAt arity args

           -- the offset of the stack args from initial Sp
        sp_stk_args
           | args_in_regs = stk_args_offset
           | no_load_regs = stk_args_offset
           | otherwise    = reg_call_sp_stk_args

           -- the stack args themselves
        this_call_stack_args
           | args_in_regs = reg_call_leftovers -- sp offsets are wrong
           | no_load_regs = this_call_args
           | otherwise    = reg_call_leftovers

        stack_args_size = sum (map argSize this_call_stack_args)

        overflow_regs = args_in_regs && length reg_locs > length reg_locs'

        save_extra_regs = (doc, (size,size))
          where
             -- we have extra arguments in registers to save
              extra_reg_locs = drop (length reg_locs') (reverse reg_locs)
              adj_reg_locs = [ (reg, off - adj + 1) |
                               (reg,off) <- extra_reg_locs ]
              adj = case extra_reg_locs of
                      (reg, fst_off):_ -> fst_off
              size = snd (last adj_reg_locs) + 1

              doc =
                text "Sp_adj(" <> int (-size) <> text ");" $$
                saveRegOffs adj_reg_locs $$
                loadSpWordOff "W_" 0 <> text " = " <>
                             mkApplyInfoName rest_args <> semi

        shuffle_extra_args = (doc, (shuffle_prof_stack, shuffle_norm_stack))
          where
           doc = vcat [ text "#if defined(PROFILING)",
                        shuffle_prof_doc,
                        text "#else",
                        shuffle_norm_doc,
                        text "#endif"]

           (shuffle_prof_doc, shuffle_prof_stack) = shuffle True
           (shuffle_norm_doc, shuffle_norm_stack) = shuffle False

           -- Sadly here we have to insert an stg_restore_cccs frame
           -- just underneath the stg_ap_*_info frame if we're
           -- profiling; see Note [jump_SAVE_CCCS]
           shuffle prof = (doc, -sp_adj)
             where
             sp_adj = sp_stk_args - 1 - offset
             offset = if prof then 2 else 0
             doc =
               vcat (map (shuffle_down (offset+1))
                      [sp_stk_args .. sp_stk_args+stack_args_size-1]) $$
               (if prof
                 then
                   loadSpWordOff "W_" (sp_stk_args+stack_args_size-3)
                     <> text " = stg_restore_cccs_info;" $$
                   loadSpWordOff "W_" (sp_stk_args+stack_args_size-2)
                     <> text " = CCCS;"
                 else empty) $$
               loadSpWordOff "W_" (sp_stk_args+stack_args_size-1)
                     <> text " = "
                     <> mkApplyInfoName rest_args <> semi $$
               text "Sp_adj(" <> int sp_adj <> text ");"

        shuffle_down j i =
             loadSpWordOff "W_" (i-j) <> text " = " <>
             loadSpWordOff "W_" i <> semi

-- The EXACT ARITY case
--
--      if (arity == 1) {
--          Sp++;
--          JMP_(GET_ENTRY(R1.cl));

    exact_arity_case
        = text "if (arity == " <> int n_args <> text ") {" $$
          let
             (reg_doc, sp')
                | no_load_regs || args_in_regs = (empty, stk_args_offset)
                | otherwise    = loadRegArgs regstatus stk_args_offset args
          in
          nest 4 (vcat [
--          text "TICK_SLOW_CALL_" <> text ticker <> text "_CORRECT();",
            reg_doc,
            text "Sp_adj(" <> int sp' <> text ");",
            if is_pap
                then text "R2 = " <> fun_info_label <> semi
                else empty,
            if is_fun_case then mb_tag_node n_args else empty,
            mkJump regstatus (text jump) live (if no_load_regs then [] else args) <> semi
          ])

-- The LARGER ARITY cases:
--
--      } else /* arity > 1 */ {
--          BUILD_PAP(1,0,(W_)&stg_ap_v_info);
--      }

    (larger_arity_doc, larger_arity_stack) = (doc, stack)
     where
       -- offsets in case we need to save regs:
       (reg_locs, leftovers, sp_offset)
           = assignRegs regstatus stk_args_slow_offset args
           -- BUILD_PAP assumes args start at offset 1

       stack | args_in_regs = (sp_offset, sp_offset)
             | otherwise    = (0,0)

       doc =
           text "} else {" $$
           let
             save_regs
                | args_in_regs =
                        text "Sp_adj(" <> int (-sp_offset) <> text ");" $$
                        saveRegOffs  reg_locs
                | otherwise =
                        empty
           in
           nest 4 (vcat [
--              text "TICK_SLOW_CALL_" <> text ticker <> text "_TOO_FEW();",
                save_regs,
                -- Before building the PAP, tag the function closure pointer
                if is_fun_case then
                  vcat [
                     text "if (arity < " <> int tAG_BITS_MAX <> text ") {",
                     text "  R1 = R1 + arity" <> semi,
                     text "}"
                   ]
                  else empty
                ,
                text macro <> char '(' <> int n_args <> comma <>
                                        int all_args_size <>
                                        text "," <> fun_info_label <>
                                        text "," <> text disamb <>
                                        text ");"
           ]) $$
           char '}'

-- Note [jump_SAVE_CCCS]

-- when profiling, if we have some extra arguments to apply that we
-- save to the stack, we must also save the current cost centre stack
-- and restore it when applying the extra arguments.  This is all
-- handled by the macro jump_SAVE_CCCS(target), defined in
-- rts/AutoApply.h.
--
-- At the jump, the stack will look like this:
--
--      ... extra args ...
--      stg_ap_pp_info
--      CCCS
--      stg_restore_cccs_info

-- --------------------------------------
-- Examine tag bits of function pointer and enter it
-- directly if needed.
-- TODO: remove the redundant case in the original code.
enterFastPath regstatus no_load_regs args_in_regs args
    | Just tag <- tagForArity (length args)
    = enterFastPathHelper tag regstatus no_load_regs args_in_regs args
enterFastPath _ _ _ _ = empty

-- Copied from Constants.hs & CgUtils.hs, i'd rather have this imported:
-- (arity,tag)
tAG_BITS = (TAG_BITS :: Int)
tAG_BITS_MAX = ((1 `shiftL` tAG_BITS) :: Int)

tagForArity :: Int -> Maybe Int
tagForArity i | i < tAG_BITS_MAX = Just i
              | otherwise        = Nothing

enterFastPathHelper :: Int
                    -> RegStatus
                    -> Bool
                    -> Bool
                    -> [ArgRep]
                    -> Doc
enterFastPathHelper tag regstatus no_load_regs args_in_regs args =
  text "if (GETTAG(R1)==" <> int tag <> text ") {" $$
  nest 4 (vcat [
    reg_doc,
    text "Sp_adj(" <> int sp' <> text ");",
    -- enter, but adjust offset with tag
    mkJump regstatus (text "%GET_ENTRY(R1-" <> int tag <> text ")") ["R1"] args <> semi
  ]) $$
  text "}"
  -- I don't totally understand this code, I copied it from
  -- exact_arity_case
  -- TODO: refactor
    where
        -- offset of arguments on the stack at slow apply calls.
    stk_args_slow_offset = 1

    stk_args_offset
        | args_in_regs = 0
        | otherwise    = stk_args_slow_offset

    (reg_doc, sp')
        | no_load_regs || args_in_regs = (empty, stk_args_offset)
        | otherwise    = loadRegArgs regstatus stk_args_offset args

tickForArity arity
    | True
    = empty
    | Just tag <- tagForArity arity
    = vcat [
            text "W_[TOTAL_CALLS] = W_[TOTAL_CALLS] + 1;",
            text "W_[SLOW_CALLS_" <> int arity <> text "] = W_[SLOW_CALLS_" <> int arity <> text "] + 1;",
            text "if (TO_W_(StgFunInfoExtra_arity(%FUN_INFO(%INFO_PTR(UNTAG(R1))))) == " <> int arity <> text " ) {",
            text "  W_[RIGHT_ARITY_" <> int arity <> text "] = W_[RIGHT_ARITY_" <> int arity <> text "] + 1;",
            text "  if (GETTAG(R1)==" <> int tag <> text ") {",
            text "    W_[TAGGED_PTR_" <> int arity <> text "] = W_[TAGGED_PTR_" <> int arity <> text "] + 1;",
            text "  } else {",
            -- force a halt when not tagged!
--          text "    W_[0]=0;",
            text "  }",
            text "}"
          ]
tickForArity _ = text "W_[TOTAL_CALLS] = W_[TOTAL_CALLS] + 1;"

-- -----------------------------------------------------------------------------
-- generate an apply function

-- args is a list of 'p', 'n', 'f', 'd' or 'l'
formalParam :: ArgRep -> Int -> Doc
formalParam V _ = empty
formalParam arg n =
    formalParamType arg <> space <>
    text "arg" <> int n <> text ", "
formalParamType arg = argRep arg

argRep F   = text "F_"
argRep D   = text "D_"
argRep L   = text "L_"
argRep P   = text "gcptr"
argRep V16 = text "V16_"
argRep V32 = text "V32_"
argRep V64 = text "V64_"
argRep _   = text "W_"

genApply :: RegStatus -> [ArgRep] -> Doc
genApply regstatus args =
   let
    fun_ret_label  = mkApplyRetName args
    fun_info_label = mkApplyInfoName args
    all_args_size  = sum (map argSize args)

    (bco_doc, bco_stack) =
       genMkPAP regstatus "BUILD_PAP" "ENTRY_LBL(stg_BCO)" ["R1"] "FUN" "BCO"
             True{-stack apply-} False{-args on stack-} False{-not a PAP-}
             args all_args_size fun_info_label {- tag stmt -}False

    (fun_doc, fun_stack) =
       genMkPAP regstatus "BUILD_PAP" "%GET_ENTRY(UNTAG(R1))" ["R1"] "FUN" "FUN"
             False{-reg apply-} False{-args on stack-} False{-not a PAP-}
             args all_args_size fun_info_label {- tag stmt -}True

    (pap_doc, pap_stack) =
       genMkPAP regstatus "NEW_PAP" "stg_PAP_apply" ["R1", "R2"] "PAP" "PAP"
             True{-stack apply-} False{-args on stack-} True{-is a PAP-}
             args all_args_size fun_info_label {- tag stmt -}False

    stack_usage = maxStack [bco_stack, fun_stack, pap_stack]
   in
    vcat [
      text "INFO_TABLE_RET(" <> mkApplyName args <> text ", " <>
        text "RET_SMALL, W_ info_ptr, " <> (cat $ zipWith formalParam args [1..]) <>
        text ")\n{",
      nest 4 (vcat [
       text "W_ info;",
       text "W_ arity;",
       text "unwind Sp = Sp + WDS(" <> int (1+all_args_size) <> text ");",

--    if fast == 1:
--        print "static void *lbls[] ="
--        print "  { [FUN]             &&fun_lbl,"
--        print "    [FUN_1_0]         &&fun_lbl,"
--        print "    [FUN_0_1]        &&fun_lbl,"
--        print "    [FUN_2_0]        &&fun_lbl,"
--        print "    [FUN_1_1]        &&fun_lbl,"
--        print "    [FUN_0_2]        &&fun_lbl,"
--        print "    [FUN_STATIC]      &&fun_lbl,"
--        print "    [PAP]             &&pap_lbl,"
--        print "    [THUNK]           &&thunk_lbl,"
--        print "    [THUNK_1_0]              &&thunk_lbl,"
--        print "    [THUNK_0_1]              &&thunk_lbl,"
--        print "    [THUNK_2_0]              &&thunk_lbl,"
--        print "    [THUNK_1_1]              &&thunk_lbl,"
--        print "    [THUNK_0_2]              &&thunk_lbl,"
--        print "    [THUNK_STATIC]    &&thunk_lbl,"
--        print "    [THUNK_SELECTOR]  &&thunk_lbl,"
--        print "    [IND]            &&ind_lbl,"
--        print "    [IND_STATIC]      &&ind_lbl,"
--        print "  };"

       tickForArity (length args),
       text "",
       text "IF_DEBUG(apply,foreign \"C\" debugBelch(\"" <> fun_ret_label <>
          text "... \"); foreign \"C\" printClosure(R1 \"ptr\"));",

       text "IF_DEBUG(sanity,foreign \"C\" checkStackFrame(Sp+WDS(" <> int (1 + all_args_size)
        <> text ")\"ptr\"));",

--       text "IF_DEBUG(sanity,checkStackChunk(Sp+" <> int (1 + all_args_size) <>
--        text ", CurrentTSO->stack + CurrentTSO->stack_size));",

--       text "TICK_SLOW_CALL(" <> int (length args) <> text ");",

       let do_assert [] _ = []
           do_assert (arg:args) offset
                | isPtr arg = this : rest
                | otherwise = rest
                where this = text "ASSERT(LOOKS_LIKE_CLOSURE_PTR(Sp("
                                 <> int offset <> text ")));"
                      rest = do_assert args (offset + argSize arg)
       in
       vcat (do_assert args 1),

       text  "again:",

       -- if pointer is tagged enter it fast!
       enterFastPath regstatus False False args,

       stackCheck regstatus args False{-args on stack-}
                  fun_info_label stack_usage,

       -- Functions can be tagged, so we untag them!
       text  "R1 = UNTAG(R1);",
       text  "info = %INFO_PTR(R1);",

--    if fast == 1:
--        print "    goto *lbls[info->type];";
--    else:
        text "switch [INVALID_OBJECT .. N_CLOSURE_TYPES] (TO_W_(%INFO_TYPE(%STD_INFO(info)))) {",
        nest 4 (vcat [

--    if fast == 1:
--        print "    bco_lbl:"
--    else:
        text "case BCO: {",
        nest 4 (vcat [
          text "arity = TO_W_(StgBCO_arity(R1));",
          text "ASSERT(arity > 0);",
          bco_doc
         ]),
        text "}",

--    if fast == 1:
--        print "    fun_lbl:"
--    else:
        text "case FUN,",
        text "     FUN_1_0,",
        text "     FUN_0_1,",
        text "     FUN_2_0,",
        text "     FUN_1_1,",
        text "     FUN_0_2,",
        text "     FUN_STATIC: {",
        nest 4 (vcat [
          text "arity = TO_W_(StgFunInfoExtra_arity(%FUN_INFO(info)));",
          text "ASSERT(arity > 0);",
          fun_doc
         ]),
        text "}",

--    if fast == 1:
--        print "    pap_lbl:"
--    else:

        text "case PAP: {",
        nest 4 (vcat [
          text "arity = TO_W_(StgPAP_arity(R1));",
          text "ASSERT(arity > 0);",
          pap_doc
         ]),
        text "}",

        text "",

--    if fast == 1:
--        print "    thunk_lbl:"
--    else:
        text "case AP,",
        text "     AP_STACK,",
        text "     BLACKHOLE,",
        text "     WHITEHOLE,",
        text "     THUNK,",
        text "     THUNK_1_0,",
        text "     THUNK_0_1,",
        text "     THUNK_2_0,",
        text "     THUNK_1_1,",
        text "     THUNK_0_2,",
        text "     THUNK_STATIC,",
        text "     THUNK_SELECTOR: {",
        nest 4 (vcat [
--          text "TICK_SLOW_CALL_UNEVALD(" <> int (length args) <> text ");",
          text "Sp(0) = " <> fun_info_label <> text ";",
          -- CAREFUL! in SMP mode, the info table may already have been
          -- overwritten by an indirection, so we must enter the original
          -- info pointer we read, don't read it again, because it might
          -- not be enterable any more.
          mkJumpSaveCCCS
            regstatus (text "%ENTRY_CODE(info)") ["R1"] args <> semi,
            -- see Note [jump_SAVE_CCCS]
          text ""
         ]),
        text "}",

--    if fast == 1:
--        print "    ind_lbl:"
--    else:
        text "case IND,",
        text "     IND_STATIC: {",
        nest 4 (vcat [
          text "R1 = StgInd_indirectee(R1);",
            -- An indirection node might contain a tagged pointer
          text "goto again;"
         ]),
        text "}",
        text "",

--    if fast == 0:

       text "default: {",
       nest 4 (
         text "foreign \"C\" barf(\"" <> fun_ret_label <> text "\") never returns;"
       ),
       text "}"

        ]),
       text "}"
      ]),

      text "}"
    ]

-- -----------------------------------------------------------------------------
-- Making a fast unknown application, args are in regs

genApplyFast :: RegStatus -> [ArgRep] -> Doc
genApplyFast regstatus args =
   let
    fun_fast_label = mkApplyFastName args
    fun_ret_label  = text "RET_LBL" <> parens (mkApplyName args)
    fun_info_label = mkApplyInfoName args
    all_args_size  = sum (map argSize args)

    (fun_doc, fun_stack) =
       genMkPAP regstatus "BUILD_PAP" "%GET_ENTRY(UNTAG(R1))" ["R1"] "FUN" "FUN"
            False{-reg apply-} True{-args in regs-} False{-not a PAP-}
            args all_args_size fun_info_label {- tag stmt -}True

    (reg_locs, leftovers, sp_offset) = assignRegs regstatus 1 args

    stack_usage = maxStack [fun_stack, (sp_offset,sp_offset)]
   in
    vcat [
     fun_fast_label,
     char '{',
     nest 4 (vcat [
        text "W_ info;",
        text "W_ arity;",

        tickForArity (length args),

        -- if pointer is tagged enter it fast!
        enterFastPath regstatus False True args,

        stackCheck regstatus args True{-args in regs-}
                   fun_info_label stack_usage,

        -- Functions can be tagged, so we untag them!
        text  "R1 = UNTAG(R1);",
        text  "info = %GET_STD_INFO(R1);",
        text "switch [INVALID_OBJECT .. N_CLOSURE_TYPES] (TO_W_(%INFO_TYPE(info))) {",
        nest 4 (vcat [
          text "case FUN,",
          text "     FUN_1_0,",
          text "     FUN_0_1,",
          text "     FUN_2_0,",
          text "     FUN_1_1,",
          text "     FUN_0_2,",
          text "     FUN_STATIC: {",
          nest 4 (vcat [
            text "arity = TO_W_(StgFunInfoExtra_arity(%GET_FUN_INFO(R1)));",
            text "ASSERT(arity > 0);",
            fun_doc
           ]),
          char '}',

          text "default: {",
          nest 4 (vcat [
             text "Sp_adj" <> parens (int (-sp_offset)) <> semi,
             saveRegOffs reg_locs,
             mkJump regstatus fun_ret_label [] args <> semi
          ]),
          char '}'
        ]),

       char '}'
     ]),
     char '}'
   ]

-- -----------------------------------------------------------------------------
-- Making a stack apply

-- These little functions are like slow entry points.  They provide
-- the layer between the PAP entry code and the function's fast entry
-- point: namely they load arguments off the stack into registers (if
-- available) and jump to the function's entry code.
--
-- On entry: R1 points to the function closure
--           arguments are on the stack starting at Sp
--
-- Invariant: the list of arguments never contains void.  Since we're only
-- interested in loading arguments off the stack here, we can ignore
-- void arguments.

mkStackApplyEntryLabel:: [ArgRep] -> Doc
mkStackApplyEntryLabel args = text "stg_ap_stk_" <> text (concatMap showArg args)

genStackApply :: RegStatus -> [ArgRep] -> Doc
genStackApply regstatus args =
  let fn_entry_label = mkStackApplyEntryLabel args in
  vcat [
    fn_entry_label,
    text "{", nest 4 body, text "}"
   ]
 where
   (assign_regs, sp') = loadRegArgs regstatus 0 args
   body = vcat [assign_regs,
                text "Sp_adj" <> parens (int sp') <> semi,
                mkJump regstatus (text "%GET_ENTRY(UNTAG(R1))") ["R1"] args <> semi
                ]

-- -----------------------------------------------------------------------------
-- Stack save entry points.
--
-- These code fragments are used to save registers on the stack at a heap
-- check failure in the entry code for a function.  We also have to save R1
-- and the return address (stg_gc_fun_info) on the stack.  See __stg_gc_fun
-- in HeapStackCheck.cmm for more details.

mkStackSaveEntryLabel :: [ArgRep] -> Doc
mkStackSaveEntryLabel args = text "stg_stk_save_" <> text (concatMap showArg args)

genStackSave :: RegStatus -> [ArgRep] -> Doc
genStackSave regstatus args =
  let fn_entry_label= mkStackSaveEntryLabel args in
  vcat [
    fn_entry_label,
    text "{", nest 4 body, text "}"
   ]
 where
   body = vcat [text "Sp_adj" <> parens (int (-sp_offset)) <> semi,
                saveRegOffs reg_locs,
                text "Sp(2) = R1;",
                text "Sp(1) =" <+> int stk_args <> semi,
                text "Sp(0) = stg_gc_fun_info;",
                text "jump stg_gc_noregs [];"
                ]

   std_frame_size = 3 -- the std bits of the frame. See StgRetFun in Closures.h,
                      -- and the comment on stg_fun_gc_gen
                      -- in HeapStackCheck.cmm.
   (reg_locs, leftovers, sp_offset) = assignRegs regstatus std_frame_size args

   -- number of words of arguments on the stack.
   stk_args = sum (map argSize leftovers) + sp_offset - std_frame_size

-- -----------------------------------------------------------------------------
-- The prologue...

main = do
  args <- getArgs
  regstatus <- case args of
                 [] -> return Registerised
                 ["-u"] -> return Unregisterised
                 _other -> do hPutStrLn stderr "syntax: genapply [-u]"
                              exitWith (ExitFailure 1)
  let the_code = vcat [
                text "// DO NOT EDIT!",
                text "// Automatically generated by utils/genapply/Main.hs",
                text "",
                text "#include \"Cmm.h\"",
                text "#include \"AutoApply.h\"",
                text "",

                vcat (intersperse (text "") $
                   map (genApply regstatus) applyTypes),
                vcat (intersperse (text "") $
                   map (genStackFns regstatus) stackApplyTypes),

                vcat (intersperse (text "") $
                   map (genApplyFast regstatus) applyTypes),

                genStackApplyArray stackApplyTypes,
                genStackSaveArray stackApplyTypes,
                genBitmapArray stackApplyTypes,

                text ""  -- add a newline at the end of the file
            ]
  -- in
  putStr (render the_code)

-- These have been shown to cover about 99% of cases in practice...
applyTypes = [
        [V],
        [F],
        [D],
        [L],
        [V16],
        [V32],
        [V64],
        [N],
        [P],
        [P,V],
        [P,P],
        [P,P,V],
        [P,P,P],
        [P,P,P,V],
        [P,P,P,P],
        [P,P,P,P,P],
        [P,P,P,P,P,P]
   ]

-- No need for V args in the stack apply cases.
-- ToDo: the stack apply and stack save code doesn't make a distinction
-- between N and P (they both live in the same register), only the bitmap
-- changes, so we could share the apply/save code between lots of cases.
--
--  NOTE: other places to change if you change stackApplyTypes:
--       - includes/rts/storage/FunTypes.h
--       - compiler/codeGen/StgCmmLayout.hs: stdPattern
stackApplyTypes = [
        [],
        [N],
        [P],
        [F],
        [D],
        [L],
        [V16],
        [V32],
        [V64],
        [N,N],
        [N,P],
        [P,N],
        [P,P],
        [N,N,N],
        [N,N,P],
        [N,P,N],
        [N,P,P],
        [P,N,N],
        [P,N,P],
        [P,P,N],
        [P,P,P],
        [P,P,P,P],
        [P,P,P,P,P],
        [P,P,P,P,P,P],
        [P,P,P,P,P,P,P],
        [P,P,P,P,P,P,P,P]
   ]

genStackFns regstatus args
  =  genStackApply regstatus args
  $$ genStackSave regstatus args

genStackApplyArray types =
  vcat [
    text "section \"relrodata\" {",
    text "stg_ap_stack_entries:",
    text "W_ 0; W_ 0; W_ 0;", -- ARG_GEN, ARG_GEN_BIG, ARG_BCO
    vcat (map arr_ent types),
    text "}"
  ]
 where
  arr_ent ty = text "W_" <+> mkStackApplyEntryLabel ty <> semi

genStackSaveArray types =
  vcat [
    text "section \"relrodata\" {",
    text "stg_stack_save_entries:",
    text "W_ 0; W_ 0; W_ 0;", -- ARG_GEN, ARG_GEN_BIG, ARG_BCO
    vcat (map arr_ent types),
    text "}"
  ]
 where
  arr_ent ty = text "W_" <+> mkStackSaveEntryLabel ty <> semi

genBitmapArray :: [[ArgRep]] -> Doc
genBitmapArray types =
  vcat [
    text "section \"rodata\" {",
    text "stg_arg_bitmaps:",
    text "W_ 0; W_ 0; W_ 0;", -- ARG_GEN, ARG_GEN_BIG, ARG_BCO
    vcat (map gen_bitmap types),
    text "}"
  ]
  where
   gen_bitmap ty = text "W_" <+> int bitmap_val <> semi
        where bitmap_val =
                (fromIntegral (mkBitmap ty) `shiftL` BITMAP_BITS_SHIFT)
                 .|. sum (map argSize ty)


------------------------------------------------------------------
-- A primop-table mangling program                              --
------------------------------------------------------------------

module Main where

import Parser
import Syntax

import Data.Char
import Data.List
import Data.Maybe ( catMaybes )
import System.Environment ( getArgs )

vecOptions :: Entry -> [(String,String,Int)]
vecOptions i =
    concat [vecs | OptionVector vecs <- opts i]

desugarVectorSpec :: Entry -> [Entry]
desugarVectorSpec i@(Section {}) = [i]
desugarVectorSpec i              = case vecOptions i of
                                     []  -> [i]
                                     vos -> map genVecEntry vos
  where
    genVecEntry :: (String,String,Int) -> Entry
    genVecEntry (con,repCon,n) =
        case i of
          PrimOpSpec {} ->
              PrimVecOpSpec { cons    = "(" ++ concat (intersperse " " [cons i, vecCat, show n, vecWidth]) ++ ")"
                            , name    = name'
                            , prefix  = pfx
                            , veclen  = n
                            , elemrep = con ++ "ElemRep"
                            , ty      = desugarTy (ty i)
                            , cat     = cat i
                            , desc    = desc i
                            , opts    = opts i
                            }
          PrimTypeSpec {} ->
              PrimVecTypeSpec { ty      = desugarTy (ty i)
                              , prefix  = pfx
                              , veclen  = n
                              , elemrep = con ++ "ElemRep"
                              , desc    = desc i
                              , opts    = opts i
                              }
          _ ->
              error "vector options can only be given for primops and primtypes"
      where
        vecCons       = con++"X"++show n++"#"
        vecCat        = conCat con
        vecWidth      = conWidth con
        pfx           = lowerHead con++"X"++show n
        vecTyName     = pfx++"PrimTy"

        name' | Just pre <- splitSuffix (name i) "Array#"     = pre++vec++"Array#"
              | Just pre <- splitSuffix (name i) "OffAddr#"   = pre++vec++"OffAddr#"
              | Just pre <- splitSuffix (name i) "ArrayAs#"   = pre++con++"ArrayAs"++vec++"#"
              | Just pre <- splitSuffix (name i) "OffAddrAs#" = pre++con++"OffAddrAs"++vec++"#"
              | otherwise                                     = init (name i)++vec ++"#"
          where
            vec = con++"X"++show n

        splitSuffix :: Eq a => [a] -> [a] -> Maybe [a]
        splitSuffix s suf
            | drop len s == suf = Just (take len s)
            | otherwise         = Nothing
          where
            len = length s - length suf

        lowerHead s = toLower (head s) : tail s

        desugarTy :: Ty -> Ty
        desugarTy (TyF s d)           = TyF (desugarTy s) (desugarTy d)
        desugarTy (TyC s d)           = TyC (desugarTy s) (desugarTy d)
        desugarTy (TyApp SCALAR [])   = TyApp (TyCon repCon) []
        desugarTy (TyApp VECTOR [])   = TyApp (VecTyCon vecCons vecTyName) []
        desugarTy (TyApp VECTUPLE []) = TyUTup (replicate n (TyApp (TyCon repCon) []))
        desugarTy (TyApp tycon ts)    = TyApp tycon (map desugarTy ts)
        desugarTy t@(TyVar {})        = t
        desugarTy (TyUTup ts)         = TyUTup (map desugarTy ts)

    conCat :: String -> String
    conCat "Int8"   = "IntVec"
    conCat "Int16"  = "IntVec"
    conCat "Int32"  = "IntVec"
    conCat "Int64"  = "IntVec"
    conCat "Word8"  = "WordVec"
    conCat "Word16" = "WordVec"
    conCat "Word32" = "WordVec"
    conCat "Word64" = "WordVec"
    conCat "Float"  = "FloatVec"
    conCat "Double" = "FloatVec"
    conCat con      = error $ "conCat: unknown type constructor " ++ con ++ "\n"

    conWidth :: String -> String
    conWidth "Int8"   = "W8"
    conWidth "Int16"  = "W16"
    conWidth "Int32"  = "W32"
    conWidth "Int64"  = "W64"
    conWidth "Word8"  = "W8"
    conWidth "Word16" = "W16"
    conWidth "Word32" = "W32"
    conWidth "Word64" = "W64"
    conWidth "Float"  = "W32"
    conWidth "Double" = "W64"
    conWidth con      = error $ "conWidth: unknown type constructor " ++ con ++ "\n"

main :: IO ()
main = getArgs >>= \args ->
       if length args /= 1 || head args `notElem` known_args
       then error ("usage: genprimopcode command < primops.txt > ...\n"
                   ++ "   where command is one of\n"
                   ++ unlines (map ("            "++) known_args)
                  )
       else
       do s <- getContents
          case parse s of
             Left err -> error ("parse error at " ++ (show err))
             Right p_o_specs@(Info _ _)
                -> seq (sanityTop p_o_specs) (
                   case head args of

                      "--data-decl"
                         -> putStr (gen_data_decl p_o_specs)

                      "--has-side-effects"
                         -> putStr (gen_switch_from_attribs
                                       "has_side_effects"
                                       "primOpHasSideEffects" p_o_specs)

                      "--out-of-line"
                         -> putStr (gen_switch_from_attribs
                                       "out_of_line"
                                       "primOpOutOfLine" p_o_specs)

                      "--commutable"
                         -> putStr (gen_switch_from_attribs
                                       "commutable"
                                       "commutableOp" p_o_specs)

                      "--code-size"
                         -> putStr (gen_switch_from_attribs
                                       "code_size"
                                       "primOpCodeSize" p_o_specs)

                      "--can-fail"
                         -> putStr (gen_switch_from_attribs
                                       "can_fail"
                                       "primOpCanFail" p_o_specs)

                      "--strictness"
                         -> putStr (gen_switch_from_attribs
                                       "strictness"
                                       "primOpStrictness" p_o_specs)

                      "--fixity"
                         -> putStr (gen_switch_from_attribs
                                       "fixity"
                                       "primOpFixity" p_o_specs)

                      "--primop-primop-info"
                         -> putStr (gen_primop_info p_o_specs)

                      "--primop-tag"
                         -> putStr (gen_primop_tag p_o_specs)

                      "--primop-list"
                         -> putStr (gen_primop_list p_o_specs)

                      "--primop-vector-uniques"
                         -> putStr (gen_primop_vector_uniques p_o_specs)

                      "--primop-vector-tys"
                         -> putStr (gen_primop_vector_tys p_o_specs)

                      "--primop-vector-tys-exports"
                         -> putStr (gen_primop_vector_tys_exports p_o_specs)

                      "--primop-vector-tycons"
                         -> putStr (gen_primop_vector_tycons p_o_specs)

                      "--make-haskell-wrappers"
                         -> putStr (gen_wrappers p_o_specs)

                      "--make-haskell-source"
                         -> putStr (gen_hs_source p_o_specs)

                      "--make-latex-doc"
                         -> putStr (gen_latex_doc p_o_specs)

                      _ -> error "Should not happen, known_args out of sync?"
                   )

known_args :: [String]
known_args
   = [ "--data-decl",
       "--has-side-effects",
       "--out-of-line",
       "--commutable",
       "--code-size",
       "--can-fail",
       "--strictness",
       "--fixity",
       "--primop-primop-info",
       "--primop-tag",
       "--primop-list",
       "--primop-vector-uniques",
       "--primop-vector-tys",
       "--primop-vector-tys-exports",
       "--primop-vector-tycons",
       "--make-haskell-wrappers",
       "--make-haskell-source",
       "--make-latex-doc"
     ]

------------------------------------------------------------------
-- Code generators -----------------------------------------------
------------------------------------------------------------------

gen_hs_source :: Info -> String
gen_hs_source (Info defaults entries) =
       "{-\n"
    ++ "This is a generated file (generated by genprimopcode).\n"
    ++ "It is not code to actually be used. Its only purpose is to be\n"
    ++ "consumed by haddock.\n"
    ++ "-}\n"
    ++ "\n"
        ++ (replicate 77 '-' ++ "\n") -- For 80-col cleanliness
        ++ "-- |\n"
        ++ "-- Module      :  GHC.Prim\n"
        ++ "-- \n"
        ++ "-- Maintainer  :  ghc-devs@haskell.org\n"
        ++ "-- Stability   :  internal\n"
        ++ "-- Portability :  non-portable (GHC extensions)\n"
        ++ "--\n"
        ++ "-- GHC\'s primitive types and operations.\n"
        ++ "-- Use GHC.Exts from the base package instead of importing this\n"
        ++ "-- module directly.\n"
        ++ "--\n"
        ++ (replicate 77 '-' ++ "\n") -- For 80-col cleanliness
        ++ "{-# LANGUAGE Unsafe #-}\n"
        ++ "{-# LANGUAGE MagicHash #-}\n"
        ++ "{-# LANGUAGE MultiParamTypeClasses #-}\n"
        ++ "{-# LANGUAGE NoImplicitPrelude #-}\n"
        ++ "{-# LANGUAGE UnboxedTuples #-}\n"
        ++ "{-# LANGUAGE NegativeLiterals #-}\n"

        ++ "{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}\n"
                -- We generate a binding for coerce, like
                --   coerce :: Coercible a b => a -> b
                --   coerce = let x = x in x
                -- and we don't want a complaint that the constraint is redundant
                -- Remember, this silly file is only for Haddock's consumption

        ++ "module GHC.Prim (\n"
        ++ unlines (map (("        " ++) . hdr) entries')
        ++ ") where\n"
    ++ "\n"
    ++ "{-\n"
        ++ unlines (map opt defaults)
    ++ "-}\n"
    ++ "import GHC.Types (Coercible)\n"

    ++ "default ()"  -- If we don't say this then the default type include Integer
                     -- so that runs off and loads modules that are not part of
                     -- package ghc-prim at all.  And that in turn somehow ends up
                     -- with Declaration for $fEqMaybe:
                     --       attempting to use module â€˜GHC.Classesâ€™
                     --       (libraries/ghc-prim/./GHC/Classes.hs) which is not loaded
                     -- coming from LoadIface.homeModError
                     -- I'm not sure precisely why; but I *am* sure that we don't need
                     -- any type-class defaulting; and it's clearly wrong to need
                     -- the base package when haddocking ghc-prim

       -- Now the main payload
    ++ "\n" ++ unlines (concatMap ent entries') ++ "\n\n\n"

     where entries' = concatMap desugarVectorSpec entries

           opt (OptionFalse n)    = n ++ " = False"
           opt (OptionTrue n)     = n ++ " = True"
           opt (OptionString n v) = n ++ " = { " ++ v ++ "}"
           opt (OptionInteger n v) = n ++ " = " ++ show v
           opt (OptionVector _)    = ""
           opt (OptionFixity mf) = "fixity" ++ " = " ++ show mf

           hdr s@(Section {})                                    = sec s
           hdr (PrimOpSpec { name = n })                         = wrapOp n ++ ","
           hdr (PrimVecOpSpec { name = n })                      = wrapOp n ++ ","
           hdr (PseudoOpSpec { name = n })                       = wrapOp n ++ ","
           hdr (PrimTypeSpec { ty = TyApp (TyCon "->") _ })      = ""
                  -- GHC lacks the syntax to explicitly export "->"
           hdr (PrimTypeSpec { ty = TyApp (TyCon n) _ })         = wrapOp n ++ ","
           hdr (PrimTypeSpec {})                                 = error $ "Illegal type spec"
           hdr (PrimVecTypeSpec { ty = TyApp (VecTyCon n _) _ }) = wrapOp n ++ ","
           hdr (PrimVecTypeSpec {})                              = error $ "Illegal type spec"

           sec s = "\n-- * " ++ escape (title s) ++ "\n"
                    ++ (unlines $ map ("-- " ++ ) $ lines $ unlatex $ escape $ "|" ++ desc s)

           ent   (Section {})         = []
           ent o@(PrimOpSpec {})      = spec o
           ent o@(PrimVecOpSpec {})   = spec o
           ent o@(PrimTypeSpec {})    = spec o
           ent o@(PrimVecTypeSpec {}) = spec o
           ent o@(PseudoOpSpec {})    = spec o

           spec o = ([ "" ] ++) . concat $
             -- Doc comments
             [ case unlatex (escape (desc o)) ++ extra (opts o) of
                 "" -> []
                 cmmt -> map ("-- " ++) $ lines $ "|" ++ cmmt

             -- Deprecations
             , [ d | Just n <- [getName o], d <- prim_deprecated (opts o) n ]

             -- Fixity
             , [ f | Just n <- [getName o], f <- prim_fixity (opts o) n ]

             -- Declarations (see Note [Placeholder declarations])
             , case o of
                 PrimOpSpec { name = n, ty = t }    -> prim_func n t
                 PrimVecOpSpec { name = n, ty = t } -> prim_func n t
                 PseudoOpSpec { name = n, ty = t }  -> prim_func n t
                 PrimTypeSpec { ty = t }    -> prim_data t
                 PrimVecTypeSpec { ty = t } -> prim_data t
                 Section { } -> error "Section is not an entity"
             ]

           extra options = case on_llvm_only options ++ can_fail options of
             [m1,m2] -> "\n\n__/Warning:/__ this " ++ m1 ++ " and " ++ m2 ++ "."
             [m] -> "\n\n__/Warning:/__ this " ++ m ++ "."
             _ -> ""

           on_llvm_only options
             = [ "is only available on LLVM"
               | Just (OptionTrue _) <- [lookup_attrib "llvm_only" options] ]

           can_fail options
             = [ "can fail with an unchecked exception"
               | Just (OptionTrue _) <- [lookup_attrib "can_fail" options] ]

           prim_deprecated options n
              = [ "{-# DEPRECATED " ++ wrapOp n ++ " \"" ++ msg ++ "\" #-}"
                | Just (OptionString _ msg)
                    <- [lookup_attrib "deprecated_msg" options] ]

           prim_fixity options n
              = [ pprFixityDir d ++ " " ++ show i ++ " " ++ asInfix n
                | OptionFixity (Just (Fixity _ i d)) <- options ]

           prim_func n t = [ wrapOp n ++ " :: " ++ pprTy t,
                             wrapOp n ++ " = " ++ funcRhs n ]

           funcRhs "tagToEnum#" = "let x = x in x"
           funcRhs nm           = wrapOp nm
              -- Special case for tagToEnum#: see Note [Placeholder declarations]

           prim_data t = [ "data " ++ pprTy t ]

           unlatex s = case s of
                '\\':'t':'e':'x':'t':'t':'t':'{':cs -> markup "@" "@" cs
                '{':'\\':'t':'e':'x':'t':'t':'t':' ':cs -> markup "@" "@" cs
                '{':'\\':'t':'t':cs -> markup "@" "@" cs
                '{':'\\':'i':'t':cs -> markup "/" "/" cs
                '{':'\\':'e':'m':cs -> markup "/" "/" cs
                c : cs -> c : unlatex cs
                "" -> ""
           markup s t xs = s ++ mk (dropWhile isSpace xs)
                where mk ""        = t
                      mk ('\n':cs) = ' ' : mk cs
                      mk ('}':cs)  = t ++ unlatex cs
                      mk (c:cs)    = c : mk cs
           escape = concatMap (\c -> if c `elem` special then '\\':c:[] else c:[])
                where special = "/'`\"@<"

-- | Extract a string representation of the name
getName :: Entry -> Maybe String
getName PrimOpSpec{ name = n } = Just n
getName PrimVecOpSpec{ name = n } = Just n
getName PseudoOpSpec{ name = n } = Just n
getName PrimTypeSpec{ ty = TyApp tc _ } = Just (show tc)
getName _ = Nothing

{- Note [Placeholder declarations]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We are generating fake declarations for things in GHC.Prim, just to
keep GHC's renamer and typechecker happy enough for what Haddock
needs.  Our main plan is to say
        foo :: <type>
        foo = foo
We have to silence GHC's complaints about unboxed-top-level declarations
with an ad-hoc fix in TcBinds: see Note [Compiling GHC.Prim] in TcBinds.

That works for all the primitive functions except tagToEnum#.
If we generate the binding
        tagToEnum# = tagToEnum#
GHC will complain about "tagToEnum# must appear applied to one argument".
We could hack GHC to silence this complaint when compiling GHC.Prim,
but it seems easier to generate
        tagToEnum# = let x = x in x
We don't do this for *all* bindings because for ones with an unboxed
RHS we would get other complaints (e.g.can't unify "*" with "#").
-}

-- | "Pretty"-print a type
pprTy :: Ty -> String
pprTy = pty
    where
          pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2
          pty (TyC t1 t2) = pbty t1 ++ " => " ++ pty t2
          pty t      = pbty t

          pbty (TyApp tc ts) = unwords (wrapOp (show tc) : map paty ts)
          pbty (TyUTup ts)   = "(# "
                            ++ concat (intersperse "," (map pty ts))
                            ++ " #)"
          pbty t             = paty t

          paty (TyVar tv)    = tv
          paty t             = "(" ++ pty t ++ ")"

-- | Turn an identifier or operator into its prefix form
wrapOp :: String -> String
wrapOp nm | isAlpha (head nm) = nm
          | otherwise         = "(" ++ nm ++ ")"

-- | Turn an identifer or operator into its infix form
asInfix :: String -> String
asInfix nm | isAlpha (head nm) = "`" ++ nm ++ "`"
           | otherwise         = nm

gen_latex_doc :: Info -> String
gen_latex_doc (Info defaults entries)
   = "\\primopdefaults{"
         ++ mk_options defaults
         ++ "}\n"
     ++ (concat (map mk_entry entries))
     where mk_entry (PrimOpSpec {cons=constr,name=n,ty=t,cat=c,desc=d,opts=o}) =
                 "\\primopdesc{"
                 ++ latex_encode constr ++ "}{"
                 ++ latex_encode n ++ "}{"
                 ++ latex_encode (zencode n) ++ "}{"
                 ++ latex_encode (show c) ++ "}{"
                 ++ latex_encode (mk_source_ty t) ++ "}{"
                 ++ latex_encode (mk_core_ty t) ++ "}{"
                 ++ d ++ "}{"
                 ++ mk_options o
                 ++ "}\n"
           mk_entry (PrimVecOpSpec {}) =
                 ""
           mk_entry (Section {title=ti,desc=d}) =
                 "\\primopsection{"
                 ++ latex_encode ti ++ "}{"
                 ++ d ++ "}\n"
           mk_entry (PrimTypeSpec {ty=t,desc=d,opts=o}) =
                 "\\primtypespec{"
                 ++ latex_encode (mk_source_ty t) ++ "}{"
                 ++ latex_encode (mk_core_ty t) ++ "}{"
                 ++ d ++ "}{"
                 ++ mk_options o
                 ++ "}\n"
           mk_entry (PrimVecTypeSpec {}) =
                 ""
           mk_entry (PseudoOpSpec {name=n,ty=t,desc=d,opts=o}) =
                 "\\pseudoopspec{"
                 ++ latex_encode (zencode n) ++ "}{"
                 ++ latex_encode (mk_source_ty t) ++ "}{"
                 ++ latex_encode (mk_core_ty t) ++ "}{"
                 ++ d ++ "}{"
                 ++ mk_options o
                 ++ "}\n"
           mk_source_ty typ = pty typ
             where pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2
                   pty (TyC t1 t2) = pbty t1 ++ " => " ++ pty t2
                   pty t = pbty t
                   pbty (TyApp tc ts) = show tc ++ (concat (map (' ':) (map paty ts)))
                   pbty (TyUTup ts) = "(# " ++ (concat (intersperse "," (map pty ts))) ++ " #)"
                   pbty t = paty t
                   paty (TyVar tv) = tv
                   paty t = "(" ++ pty t ++ ")"

           mk_core_ty typ = foralls ++ (pty typ)
             where pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2
                   pty (TyC t1 t2) = pbty t1 ++ " => " ++ pty t2
                   pty t = pbty t
                   pbty (TyApp tc ts) = (zencode (show tc)) ++ (concat (map (' ':) (map paty ts)))
                   pbty (TyUTup ts) = (zencode (utuplenm (length ts))) ++ (concat ((map (' ':) (map paty ts))))
                   pbty t = paty t
                   paty (TyVar tv) = zencode tv
                   paty (TyApp tc []) = zencode (show tc)
                   paty t = "(" ++ pty t ++ ")"
                   utuplenm 1 = "(# #)"
                   utuplenm n = "(#" ++ (replicate (n-1) ',') ++ "#)"
                   foralls = if tvars == [] then "" else "%forall " ++ (tbinds tvars)
                   tvars = tvars_of typ
                   tbinds [] = ". "
                   tbinds ("o":tbs) = "(o::?) " ++ (tbinds tbs)
                   tbinds (tv:tbs) = tv ++ " " ++ (tbinds tbs)
           tvars_of (TyF t1 t2) = tvars_of t1 `union` tvars_of t2
           tvars_of (TyC t1 t2) = tvars_of t1 `union` tvars_of t2
           tvars_of (TyApp _ ts) = foldl union [] (map tvars_of ts)
           tvars_of (TyUTup ts) = foldr union [] (map tvars_of ts)
           tvars_of (TyVar tv) = [tv]

           mk_options o =
             "\\primoptions{"
              ++ mk_has_side_effects o ++ "}{"
              ++ mk_out_of_line o ++ "}{"
              ++ mk_commutable o ++ "}{"
              ++ mk_needs_wrapper o ++ "}{"
              ++ mk_can_fail o ++ "}{"
              ++ mk_fixity o ++ "}{"
              ++ latex_encode (mk_strictness o) ++ "}{"
              ++ "}"

           mk_has_side_effects o = mk_bool_opt o "has_side_effects" "Has side effects." "Has no side effects."
           mk_out_of_line o = mk_bool_opt o "out_of_line" "Implemented out of line." "Implemented in line."
           mk_commutable o = mk_bool_opt o "commutable" "Commutable." "Not commutable."
           mk_needs_wrapper o = mk_bool_opt o "needs_wrapper" "Needs wrapper." "Needs no wrapper."
           mk_can_fail o = mk_bool_opt o "can_fail" "Can fail." "Cannot fail."

           mk_bool_opt o opt_name if_true if_false =
             case lookup_attrib opt_name o of
               Just (OptionTrue _) -> if_true
               Just (OptionFalse _) -> if_false
               Just (OptionString _ _) -> error "String value for boolean option"
               Just (OptionInteger _ _) -> error "Integer value for boolean option"
               Just (OptionFixity _) -> error "Fixity value for boolean option"
               Just (OptionVector _) -> error "vector template for boolean option"
               Nothing -> ""

           mk_strictness o =
             case lookup_attrib "strictness" o of
               Just (OptionString _ s) -> s  -- for now
               Just _ -> error "Wrong value for strictness"
               Nothing -> ""

           mk_fixity o = case lookup_attrib "fixity" o of
             Just (OptionFixity (Just (Fixity _ i d)))
               -> pprFixityDir d ++ " " ++ show i
             _ -> ""

           zencode xs =
             case maybe_tuple xs of
                Just n  -> n            -- Tuples go to Z2T etc
                Nothing -> concat (map encode_ch xs)
             where
               maybe_tuple "(# #)" = Just("Z1H")
               maybe_tuple ('(' : '#' : cs) = case count_commas (0::Int) cs of
                                                (n, '#' : ')' : _) -> Just ('Z' : shows (n+1) "H")
                                                _                  -> Nothing
               maybe_tuple "()" = Just("Z0T")
               maybe_tuple ('(' : cs)       = case count_commas (0::Int) cs of
                                                (n, ')' : _) -> Just ('Z' : shows (n+1) "T")
                                                _            -> Nothing
               maybe_tuple _                 = Nothing

               count_commas :: Int -> String -> (Int, String)
               count_commas n (',' : cs) = count_commas (n+1) cs
               count_commas n cs          = (n,cs)

               unencodedChar :: Char -> Bool    -- True for chars that don't need encoding
               unencodedChar 'Z' = False
               unencodedChar 'z' = False
               unencodedChar c   = isAlphaNum c

               encode_ch :: Char -> String
               encode_ch c | unencodedChar c = [c]      -- Common case first

               -- Constructors
               encode_ch '('  = "ZL"    -- Needed for things like (,), and (->)
               encode_ch ')'  = "ZR"    -- For symmetry with (
               encode_ch '['  = "ZM"
               encode_ch ']'  = "ZN"
               encode_ch ':'  = "ZC"
               encode_ch 'Z'  = "ZZ"

               -- Variables
               encode_ch 'z'  = "zz"
               encode_ch '&'  = "za"
               encode_ch '|'  = "zb"
               encode_ch '^'  = "zc"
               encode_ch '$'  = "zd"
               encode_ch '='  = "ze"
               encode_ch '>'  = "zg"
               encode_ch '#'  = "zh"
               encode_ch '.'  = "zi"
               encode_ch '<'  = "zl"
               encode_ch '-'  = "zm"
               encode_ch '!'  = "zn"
               encode_ch '+'  = "zp"
               encode_ch '\'' = "zq"
               encode_ch '\\' = "zr"
               encode_ch '/'  = "zs"
               encode_ch '*'  = "zt"
               encode_ch '_'  = "zu"
               encode_ch '%'  = "zv"
               encode_ch c    = 'z' : shows (ord c) "U"

           latex_encode [] = []
           latex_encode (c:cs) | c `elem` "#$%&_^{}" = "\\" ++ c:(latex_encode cs)
           latex_encode ('~':cs) = "\\verb!~!" ++ (latex_encode cs)
           latex_encode ('\\':cs) = "$\\backslash$" ++ (latex_encode cs)
           latex_encode (c:cs) = c:(latex_encode cs)

gen_wrappers :: Info -> String
gen_wrappers (Info _ entries)
   =    "{-# LANGUAGE MagicHash, NoImplicitPrelude, UnboxedTuples #-}\n"
        -- Dependencies on Prelude must be explicit in libraries/base, but we
        -- don't need the Prelude here so we add NoImplicitPrelude.
     ++ "{-# OPTIONS_GHC -Wno-deprecations #-}\n"
     ++ "module GHC.PrimopWrappers where\n"
     ++ "import qualified GHC.Prim\n"
     ++ "import GHC.Tuple ()\n"
     ++ "import GHC.Prim (" ++ types ++ ")\n"
     ++ unlines (concatMap f specs)
     where
        specs = filter (not.dodgy) $
                filter (not.is_llvm_only) $
                filter is_primop entries
        tycons = foldr union [] $ map (tyconsIn . ty) specs
        tycons' = filter (`notElem` [TyCon "()", TyCon "Bool"]) tycons
        types = concat $ intersperse ", " $ map show tycons'
        f spec = let args = map (\n -> "a" ++ show n) [1 .. arity (ty spec)]
                     src_name = wrap (name spec)
                     lhs = src_name ++ " " ++ unwords args
                     rhs = "(GHC.Prim." ++ name spec ++ ") " ++ unwords args
                 in ["{-# NOINLINE " ++ src_name ++ " #-}",
                     src_name ++ " :: " ++ pprTy (ty spec),
                     lhs ++ " = " ++ rhs]
        wrap nm | isLower (head nm) = nm
                | otherwise = "(" ++ nm ++ ")"

        dodgy spec
           = name spec `elem`
             [-- tagToEnum# is really magical, and can't have
              -- a wrapper since its implementation depends on
              -- the type of its result
              "tagToEnum#"
             ]

        is_llvm_only :: Entry -> Bool
        is_llvm_only entry =
            case lookup_attrib "llvm_only" (opts entry) of
              Just (OptionTrue _) -> True
              _                   -> False

gen_primop_list :: Info -> String
gen_primop_list (Info _ entries)
   = unlines (
        [      "   [" ++ cons first       ]
        ++
        map (\p -> "   , " ++ cons p) rest
        ++
        [     "   ]"     ]
     ) where (first:rest) = concatMap desugarVectorSpec (filter is_primop entries)

mIN_VECTOR_UNIQUE :: Int
mIN_VECTOR_UNIQUE = 300

gen_primop_vector_uniques :: Info -> String
gen_primop_vector_uniques (Info _ entries)
   = unlines $
     concatMap mkVecUnique (specs `zip` [mIN_VECTOR_UNIQUE..])
  where
    specs = concatMap desugarVectorSpec (filter is_vector (filter is_primtype entries))

    mkVecUnique :: (Entry, Int) -> [String]
    mkVecUnique (i, unique) =
        [ key_id ++ " :: Unique"
        , key_id ++ " = mkPreludeTyConUnique " ++ show unique
        ]
      where
        key_id = prefix i ++ "PrimTyConKey"

gen_primop_vector_tys :: Info -> String
gen_primop_vector_tys (Info _ entries)
   = unlines $
     concatMap mkVecTypes specs
  where
    specs = concatMap desugarVectorSpec (filter is_vector (filter is_primtype entries))

    mkVecTypes :: Entry -> [String]
    mkVecTypes i =
        [ name_id ++ " :: Name"
        , name_id ++ " = mkPrimTc (fsLit \"" ++ pprTy (ty i) ++ "\") " ++ key_id ++ " " ++ tycon_id
        , ty_id ++ " :: Type"
        , ty_id ++ " = mkTyConTy " ++ tycon_id
        , tycon_id ++ " :: TyCon"
        , tycon_id ++ " = pcPrimTyCon0 " ++ name_id ++
                      " (VecRep " ++ show (veclen i) ++ " " ++ elemrep i ++ ")"
        ]
      where
        key_id   = prefix i ++ "PrimTyConKey"
        name_id  = prefix i ++ "PrimTyConName"
        ty_id    = prefix i ++ "PrimTy"
        tycon_id = prefix i ++ "PrimTyCon"

gen_primop_vector_tys_exports :: Info -> String
gen_primop_vector_tys_exports (Info _ entries)
   = unlines $
    map mkVecTypes specs
  where
    specs = concatMap desugarVectorSpec (filter is_vector (filter is_primtype entries))

    mkVecTypes :: Entry -> String
    mkVecTypes i =
        "        " ++ ty_id ++ ", " ++ tycon_id ++ ","
      where
        ty_id    = prefix i ++ "PrimTy"
        tycon_id = prefix i ++ "PrimTyCon"

gen_primop_vector_tycons :: Info -> String
gen_primop_vector_tycons (Info _ entries)
   = unlines $
     map mkVecTypes specs
  where
    specs = concatMap desugarVectorSpec (filter is_vector (filter is_primtype entries))

    mkVecTypes :: Entry -> String
    mkVecTypes i =
        "    , " ++ tycon_id
      where
        tycon_id = prefix i ++ "PrimTyCon"

gen_primop_tag :: Info -> String
gen_primop_tag (Info _ entries)
   = unlines (max_def_type : max_def :
              tagOf_type : zipWith f primop_entries [1 :: Int ..])
     where
        primop_entries = concatMap desugarVectorSpec $ filter is_primop entries
        tagOf_type = "primOpTag :: PrimOp -> Int"
        f i n = "primOpTag " ++ cons i ++ " = " ++ show n
        max_def_type = "maxPrimOpTag :: Int"
        max_def      = "maxPrimOpTag = " ++ show (length primop_entries)

gen_data_decl :: Info -> String
gen_data_decl (Info _ entries) =
    "data PrimOp\n   = " ++ head conss ++ "\n"
     ++ unlines (map ("   | "++) (tail conss))
  where
    conss = map genCons (filter is_primop entries)

    genCons :: Entry -> String
    genCons entry =
        case vecOptions entry of
          [] -> cons entry
          _  -> cons entry ++ " PrimOpVecCat Length Width"

gen_switch_from_attribs :: String -> String -> Info -> String
gen_switch_from_attribs attrib_name fn_name (Info defaults entries)
   = let defv = lookup_attrib attrib_name defaults
         alternatives = catMaybes (map mkAlt (filter is_primop entries))

         getAltRhs (OptionFalse _)    = "False"
         getAltRhs (OptionTrue _)     = "True"
         getAltRhs (OptionInteger _ i) = show i
         getAltRhs (OptionString _ s) = s
         getAltRhs (OptionVector _) = "True"
         getAltRhs (OptionFixity mf) = show mf

         mkAlt po
            = case lookup_attrib attrib_name (opts po) of
                 Nothing -> Nothing
                 Just xx -> case vecOptions po of
                              [] -> Just (fn_name ++ " " ++ cons po ++ " = " ++ getAltRhs xx)
                              _  -> Just (fn_name ++ " (" ++ cons po ++ " _ _ _) = " ++ getAltRhs xx)

     in
         case defv of
            Nothing -> error ("gen_switch_from: " ++ attrib_name)
            Just xx
               -> unlines alternatives
                  ++ fn_name ++ " _ = " ++ getAltRhs xx ++ "\n"

------------------------------------------------------------------
-- Create PrimOpInfo text from PrimOpSpecs -----------------------
------------------------------------------------------------------

gen_primop_info :: Info -> String
gen_primop_info (Info _ entries)
   = unlines (map mkPOItext (concatMap desugarVectorSpec (filter is_primop entries)))

mkPOItext :: Entry -> String
mkPOItext i = mkPOI_LHS_text i ++ mkPOI_RHS_text i

mkPOI_LHS_text :: Entry -> String
mkPOI_LHS_text i
   = "primOpInfo " ++ cons i ++ " = "

mkPOI_RHS_text :: Entry -> String
mkPOI_RHS_text i
   = case cat i of
        Compare
           -> case ty i of
                 TyF t1 (TyF _ _)
                    -> "mkCompare " ++ sl_name i ++ ppType t1
                 _ -> error "Type error in comparison op"
        Monadic
           -> case ty i of
                 TyF t1 _
                    -> "mkMonadic " ++ sl_name i ++ ppType t1
                 _ -> error "Type error in monadic op"
        Dyadic
           -> case ty i of
                 TyF t1 (TyF _ _)
                    -> "mkDyadic " ++ sl_name i ++ ppType t1
                 _ -> error "Type error in dyadic op"
        GenPrimOp
           -> let (argTys, resTy) = flatTys (ty i)
                  tvs = nub (tvsIn (ty i))
              in
                  "mkGenPrimOp " ++ sl_name i ++ " "
                      ++ listify (map ppTyVar tvs) ++ " "
                      ++ listify (map ppType argTys) ++ " "
                      ++ "(" ++ ppType resTy ++ ")"

sl_name :: Entry -> String
sl_name i = "(fsLit \"" ++ name i ++ "\") "

ppTyVar :: String -> String
ppTyVar "a" = "alphaTyVar"
ppTyVar "b" = "betaTyVar"
ppTyVar "c" = "gammaTyVar"
ppTyVar "s" = "deltaTyVar"
ppTyVar "o" = "runtimeRep1TyVar, openAlphaTyVar"
ppTyVar _   = error "Unknown type var"

ppType :: Ty -> String
ppType (TyApp (TyCon "Any")         []) = "anyTy"
ppType (TyApp (TyCon "Bool")        []) = "boolTy"

ppType (TyApp (TyCon "Int#")        []) = "intPrimTy"
ppType (TyApp (TyCon "Int8#")       []) = "int8PrimTy"
ppType (TyApp (TyCon "Int16#")      []) = "int16PrimTy"
ppType (TyApp (TyCon "Int32#")      []) = "int32PrimTy"
ppType (TyApp (TyCon "Int64#")      []) = "int64PrimTy"
ppType (TyApp (TyCon "Char#")       []) = "charPrimTy"
ppType (TyApp (TyCon "Word#")       []) = "wordPrimTy"
ppType (TyApp (TyCon "Word8#")      []) = "word8PrimTy"
ppType (TyApp (TyCon "Word16#")     []) = "word16PrimTy"
ppType (TyApp (TyCon "Word32#")     []) = "word32PrimTy"
ppType (TyApp (TyCon "Word64#")     []) = "word64PrimTy"
ppType (TyApp (TyCon "Addr#")       []) = "addrPrimTy"
ppType (TyApp (TyCon "Float#")      []) = "floatPrimTy"
ppType (TyApp (TyCon "Double#")     []) = "doublePrimTy"
ppType (TyApp (TyCon "ByteArray#")  []) = "byteArrayPrimTy"
ppType (TyApp (TyCon "RealWorld")   []) = "realWorldTy"
ppType (TyApp (TyCon "ThreadId#")   []) = "threadIdPrimTy"
ppType (TyApp (TyCon "ForeignObj#") []) = "foreignObjPrimTy"
ppType (TyApp (TyCon "BCO#")        []) = "bcoPrimTy"
ppType (TyApp (TyCon "Compact#")    []) = "compactPrimTy"
ppType (TyApp (TyCon "()")          []) = "unitTy"      -- unitTy is TysWiredIn's name for ()

ppType (TyVar "a")                      = "alphaTy"
ppType (TyVar "b")                      = "betaTy"
ppType (TyVar "c")                      = "gammaTy"
ppType (TyVar "s")                      = "deltaTy"
ppType (TyVar "o")                      = "openAlphaTy"

ppType (TyApp (TyCon "State#") [x])             = "mkStatePrimTy " ++ ppType x
ppType (TyApp (TyCon "MutVar#") [x,y])          = "mkMutVarPrimTy " ++ ppType x
                                                   ++ " " ++ ppType y
ppType (TyApp (TyCon "MutableArray#") [x,y])    = "mkMutableArrayPrimTy " ++ ppType x
                                                   ++ " " ++ ppType y
ppType (TyApp (TyCon "MutableArrayArray#") [x]) = "mkMutableArrayArrayPrimTy " ++ ppType x
ppType (TyApp (TyCon "SmallMutableArray#") [x,y]) = "mkSmallMutableArrayPrimTy " ++ ppType x
                                                    ++ " " ++ ppType y
ppType (TyApp (TyCon "MutableByteArray#") [x])  = "mkMutableByteArrayPrimTy "
                                                   ++ ppType x
ppType (TyApp (TyCon "Array#") [x])             = "mkArrayPrimTy " ++ ppType x
ppType (TyApp (TyCon "ArrayArray#") [])         = "mkArrayArrayPrimTy"
ppType (TyApp (TyCon "SmallArray#") [x])        = "mkSmallArrayPrimTy " ++ ppType x

ppType (TyApp (TyCon "Weak#")       [x]) = "mkWeakPrimTy " ++ ppType x
ppType (TyApp (TyCon "StablePtr#")  [x]) = "mkStablePtrPrimTy " ++ ppType x
ppType (TyApp (TyCon "StableName#") [x]) = "mkStableNamePrimTy " ++ ppType x

ppType (TyApp (TyCon "MVar#") [x,y])     = "mkMVarPrimTy " ++ ppType x
                                           ++ " " ++ ppType y
ppType (TyApp (TyCon "TVar#") [x,y])     = "mkTVarPrimTy " ++ ppType x
                                           ++ " " ++ ppType y

ppType (TyApp (VecTyCon _ pptc) [])      = pptc

ppType (TyUTup ts) = "(mkTupleTy Unboxed "
                     ++ listify (map ppType ts) ++ ")"

ppType (TyF s d) = "(mkVisFunTy (" ++ ppType s ++ ") (" ++ ppType d ++ "))"
ppType (TyC s d) = "(mkInvisFunTy (" ++ ppType s ++ ") (" ++ ppType d ++ "))"

ppType other
   = error ("ppType: can't handle: " ++ show other ++ "\n")

pprFixityDir :: FixityDirection -> String
pprFixityDir InfixN = "infix"
pprFixityDir InfixL = "infixl"
pprFixityDir InfixR = "infixr"

listify :: [String] -> String
listify ss = "[" ++ concat (intersperse ", " ss) ++ "]"

flatTys :: Ty -> ([Ty],Ty)
flatTys (TyF t1 t2) = case flatTys t2 of (ts,t) -> (t1:ts,t)
flatTys (TyC t1 t2) = case flatTys t2 of (ts,t) -> (t1:ts,t)
flatTys other       = ([],other)

tvsIn :: Ty -> [TyVar]
tvsIn (TyF t1 t2)    = tvsIn t1 ++ tvsIn t2
tvsIn (TyC t1 t2)    = tvsIn t1 ++ tvsIn t2
tvsIn (TyApp _ tys)  = concatMap tvsIn tys
tvsIn (TyVar tv)     = [tv]
tvsIn (TyUTup tys)   = concatMap tvsIn tys

tyconsIn :: Ty -> [TyCon]
tyconsIn (TyF t1 t2)    = tyconsIn t1 `union` tyconsIn t2
tyconsIn (TyC t1 t2)    = tyconsIn t1 `union` tyconsIn t2
tyconsIn (TyApp tc tys) = foldr union [tc] $ map tyconsIn tys
tyconsIn (TyVar _)      = []
tyconsIn (TyUTup tys)   = foldr union [] $ map tyconsIn tys

arity :: Ty -> Int
arity = length . fst . flatTys


module ParserM (
    -- Parser Monad
    ParserM(..), AlexInput, run_parser,
    -- Parser state
    St,
    StartCode, start_code, set_start_code,
    inc_brace_depth, dec_brace_depth,
    -- Tokens
    Token(..),
    -- Actions
    Action, andBegin, mkT, mkTv,
    -- Positions
    get_pos, show_pos,
    -- Input
    alexGetChar, alexGetByte, alexInputPrevChar, input, position,
    -- Other
    happyError
 ) where

import Control.Applicative
import Prelude

import Control.Monad (ap, liftM)
import Data.Word (Word8)
import Data.Char (ord)

-- Parser Monad
newtype ParserM a = ParserM (AlexInput -> St -> Either String (AlexInput, St, a))

instance Functor ParserM where
  fmap = liftM

instance Applicative ParserM where
  pure  = return
  (<*>) = ap

instance Monad ParserM where
    ParserM m >>= k = ParserM $ \i s -> case m i s of
                                            Right (i', s', x) ->
                                                case k x of
                                                    ParserM y -> y i' s'
                                            Left err ->
                                                Left err
    return a = ParserM $ \i s -> Right (i, s, a)
    fail err = ParserM $ \_ _ -> Left err

run_parser :: ParserM a -> (String -> Either String a)
run_parser (ParserM f)
 = \s -> case f (AlexInput init_pos s) init_state of
             Left es -> Left es
             Right (_, _, x) -> Right x

-- Parser state

data St = St {
              start_code :: !StartCode,
              brace_depth :: !Int
          }
    deriving Show
type StartCode = Int

init_state :: St
init_state = St {
                 start_code = 0,
                 brace_depth = 0
             }

-- Tokens

data Token = TEOF
           | TArrow
           | TDArrow
           | TEquals
           | TComma
           | TOpenParen
           | TCloseParen
           | TOpenParenHash
           | THashCloseParen
           | TOpenBrace
           | TCloseBrace
           | TOpenBracket
           | TCloseBracket
           | TOpenAngle
           | TCloseAngle
           | TSection
           | TPrimop
           | TPseudoop
           | TPrimtype
           | TWith
           | TDefaults
           | TTrue
           | TFalse
           | TDyadic
           | TMonadic
           | TCompare
           | TGenPrimOp
           | TThatsAllFolks
           | TLowerName String
           | TUpperName String
           | TString String
           | TNoBraces String
           | TInteger Int
           | TFixity
           | TInfixN
           | TInfixL
           | TInfixR
           | TNothing
           | TVector
           | TSCALAR
           | TVECTOR
           | TVECTUPLE
    deriving Show

-- Actions

type Action = String -> ParserM Token

set_start_code :: StartCode -> ParserM ()
set_start_code sc = ParserM $ \i st -> Right (i, st { start_code = sc }, ())

inc_brace_depth :: ParserM ()
inc_brace_depth = ParserM $ \i st ->
                  Right (i, st { brace_depth = brace_depth st + 1 }, ())

dec_brace_depth :: ParserM ()
dec_brace_depth = ParserM $ \i st ->
                  let bd = brace_depth st - 1
                      sc = if bd == 0 then 0 else 1
                  in Right (i, st { brace_depth = bd, start_code = sc }, ())

andBegin :: Action -> StartCode -> Action
(act `andBegin` sc) x = do set_start_code sc
                           act x

mkT :: Token -> Action
mkT t = mkTv (const t)

mkTv :: (String -> Token) -> Action
mkTv f str = ParserM (\i st -> Right (i, st, f str))

-- Positions

data Pos = Pos !Int{- Line -} !Int{- Column -}

get_pos :: ParserM Pos
get_pos = ParserM $ \i@(AlexInput p _) st -> Right (i, st, p)

alexMove :: Pos -> Char -> Pos
alexMove (Pos l _) '\n' = Pos (l+1) 1
alexMove (Pos l c) '\t' = Pos l ((c+8) `div` 8 * 8)
alexMove (Pos l c) _    = Pos l (c+1)

init_pos :: Pos
init_pos = Pos 1 1

show_pos :: Pos -> String
show_pos (Pos l c) = "line " ++ show l ++ ", column " ++ show c

-- Input

data AlexInput = AlexInput {position :: !Pos, input :: String}

-- alexGetByte is for Alex >= 3.0, alexGetChar for earlier
-- XXX no UTF-8; we should do this properly sometime
alexGetByte :: AlexInput -> Maybe (Word8,AlexInput)
alexGetByte (AlexInput p (x:xs)) = Just (fromIntegral (ord x),
                                         AlexInput (alexMove p x) xs)
alexGetByte (AlexInput _ []) = Nothing

alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
alexGetChar (AlexInput p (x:xs)) = Just (x, AlexInput (alexMove p x) xs)
alexGetChar (AlexInput _ []) = Nothing

alexInputPrevChar :: AlexInput -> Char
alexInputPrevChar _ = error "Lexer doesn't implement alexInputPrevChar"

happyError :: ParserM a
happyError = do p <- get_pos
                fail $ "Parse error at " ++ show_pos p


module Syntax where

import Data.List

------------------------------------------------------------------
-- Abstract syntax -----------------------------------------------
------------------------------------------------------------------

-- info for all primops; the totality of the info in primops.txt(.pp)
data Info
   = Info [Option] [Entry]   -- defaults, primops
     deriving Show

-- info for one primop
data Entry
    = PrimOpSpec { cons  :: String,      -- PrimOp name
                   name  :: String,      -- name in prog text
                   ty    :: Ty,          -- type
                   cat   :: Category,    -- category
                   desc  :: String,      -- description
                   opts  :: [Option] }   -- default overrides
    | PrimVecOpSpec { cons    :: String,    -- PrimOp name
                      name    :: String,    -- name in prog text
                      prefix  :: String,    -- prefix for generated names
                      veclen  :: Int,       -- vector length
                      elemrep :: String,    -- vector ElemRep
                      ty      :: Ty,        -- type
                      cat     :: Category,  -- category
                      desc    :: String,    -- description
                      opts    :: [Option] } -- default overrides
    | PseudoOpSpec { name  :: String,      -- name in prog text
                     ty    :: Ty,          -- type
                     desc  :: String,      -- description
                     opts  :: [Option] }   -- default overrides
    | PrimTypeSpec { ty    :: Ty,      -- name in prog text
                     desc  :: String,      -- description
                     opts  :: [Option] }   -- default overrides
    | PrimVecTypeSpec { ty    :: Ty,      -- name in prog text
                        prefix  :: String,    -- prefix for generated names
                        veclen  :: Int,       -- vector length
                        elemrep :: String,    -- vector ElemRep
                        desc  :: String,      -- description
                        opts  :: [Option] }   -- default overrides
    | Section { title :: String,         -- section title
                desc  :: String }        -- description
    deriving Show

is_primop :: Entry -> Bool
is_primop (PrimOpSpec _ _ _ _ _ _) = True
is_primop _ = False

is_primtype :: Entry -> Bool
is_primtype (PrimTypeSpec {}) = True
is_primtype _ = False

-- a binding of property to value
data Option
   = OptionFalse  String          -- name = False
   | OptionTrue   String          -- name = True
   | OptionString String String   -- name = { ... unparsed stuff ... }
   | OptionInteger String Int     -- name = <int>
   | OptionVector [(String,String,Int)]  -- name = [(,...),...]
   | OptionFixity (Maybe Fixity)  -- fixity = infix{,l,r} <int> | Nothing
     deriving Show

-- categorises primops
data Category
   = Dyadic | Monadic | Compare | GenPrimOp
     deriving Show

-- types
data Ty
   = TyF    Ty Ty
   | TyC    Ty Ty -- We only allow one constraint, keeps the grammar simpler
   | TyApp  TyCon [Ty]
   | TyVar  TyVar
   | TyUTup [Ty]   -- unboxed tuples; just a TyCon really,
                   -- but convenient like this
   deriving (Eq,Show)

type TyVar = String

data TyCon = TyCon String
           | SCALAR
           | VECTOR
           | VECTUPLE
           | VecTyCon String String
  deriving (Eq, Ord)

instance Show TyCon where
    show (TyCon tc)      = tc
    show SCALAR          = "SCALAR"
    show VECTOR          = "VECTOR"
    show VECTUPLE        = "VECTUPLE"
    show (VecTyCon tc _) = tc

-- Follow definitions of Fixity and FixityDirection in GHC

-- The SourceText exists so that it matches the SourceText field in
-- BasicTypes.Fixity
data Fixity = Fixity SourceText Int FixityDirection
  deriving (Eq, Show)

data FixityDirection = InfixN | InfixL | InfixR
  deriving (Eq, Show)

data SourceText = SourceText String
                | NoSourceText
                deriving (Eq,Show)

------------------------------------------------------------------
-- Sanity checking -----------------------------------------------
------------------------------------------------------------------

{- Do some simple sanity checks:
    * all the default field names are unique
    * for each PrimOpSpec, all override field names are unique
    * for each PrimOpSpec, all overriden field names
          have a corresponding default value
    * that primop types correspond in certain ways to the
      Category: eg if Comparison, the type must be of the form
         T -> T -> Bool.
   Dies with "error" if there's a problem, else returns ().
-}
myseqAll :: [()] -> a -> a
myseqAll (():ys) x = myseqAll ys x
myseqAll []      x = x

sanityTop :: Info -> ()
sanityTop (Info defs entries)
   = let opt_names = map get_attrib_name defs
         primops = filter is_primop entries
     in
     if   length opt_names /= length (nub opt_names)
     then error ("non-unique default attribute names: " ++ show opt_names ++ "\n")
     else myseqAll (map (sanityPrimOp opt_names) primops) ()

sanityPrimOp :: [String] -> Entry -> ()
sanityPrimOp def_names p
   = let p_names = map get_attrib_name (opts p)
         p_names_ok
            = length p_names == length (nub p_names)
              && all (`elem` def_names) p_names
         ty_ok = sane_ty (cat p) (ty p)
     in
         if   not p_names_ok
         then error ("attribute names are non-unique or have no default in\n" ++
                     "info for primop " ++ cons p ++ "\n")
         else
         if   not ty_ok
         then error ("type of primop " ++ cons p ++ " doesn't make sense w.r.t" ++
                     " category " ++ show (cat p) ++ "\n")
         else ()

sane_ty :: Category -> Ty -> Bool
sane_ty Compare (TyF t1 (TyF t2 td))
   | t1 == t2 && td == TyApp (TyCon "Int#") []  = True
sane_ty Monadic (TyF t1 td)
   | t1 == td  = True
sane_ty Dyadic (TyF t1 (TyF t2 td))
   | t1 == td && t2 == td  = True
sane_ty GenPrimOp _
   = True
sane_ty _ _
   = False

get_attrib_name :: Option -> String
get_attrib_name (OptionFalse nm) = nm
get_attrib_name (OptionTrue nm)  = nm
get_attrib_name (OptionString nm _) = nm
get_attrib_name (OptionInteger nm _) = nm
get_attrib_name (OptionVector _) = "vector"
get_attrib_name (OptionFixity _) = "fixity"

lookup_attrib :: String -> [Option] -> Maybe Option
lookup_attrib _ [] = Nothing
lookup_attrib nm (a:as)
    = if get_attrib_name a == nm then Just a else lookup_attrib nm as

is_vector :: Entry -> Bool
is_vector i = case lookup_attrib "vector" (opts i) of
                Nothing -> False
                _       -> True